home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / 4c.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  73KB  |  2,355 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #include "4.h"
  10. #include "attr.h"
  11. #include "setp.h"
  12. #include "libp.h"
  13. #include "miscp.h"
  14. #include "smiscp.h"
  15. #include "errmsgp.h"
  16. #include "nodesp.h"
  17. #include "dclmapp.h"
  18. #include "evalp.h"
  19. #include "chapp.h"
  20.  
  21. static int prev_error_message;
  22. static Triplet *is_partition(Tuple, int, int);
  23. static Tuple sort_case(Tuple);
  24. static int tcompar(Triplet **, Triplet **);
  25. static int abs_val(int);
  26. static void complete_a_aggregate(Tuple, Tuple, Symbol, int, Node);
  27. static void complete_component(Tuple, Tuple, Symbol, int, Node);
  28. static Node new_comp_assoc(Symbol, Node);
  29. static void resolve_r_component(Node, Symbol, Tuple);
  30. static Symbol check_discriminant_dependence(Symbol, Tuple);
  31. static int in_gen_types(Symbol);
  32. static int in_multiple_types(Symbol);
  33. static int is_integer_type(Symbol);
  34. static Triplet *triplet_new();
  35.  
  36. int can_constrain(Symbol d_type)                          /*;can_constrain*/
  37. {
  38.     /* Determine whether an object, actual parameter,  type def, etc.  can
  39.      * receive a constraint.The predicate -is_unconstrained- used in decla-
  40.      * rations is too weak here, because it returns false on discriminated
  41.      * records with default values.
  42.      */
  43.  
  44.     if ((NATURE(d_type) == na_array)
  45.       || (is_record(d_type) && NATURE(d_type) != na_subtype
  46.       && has_discriminants(d_type)))
  47.         return TRUE;
  48.     else
  49.         return FALSE;
  50. }
  51.  
  52. Set valid_array_expn(Node expn)                             /*;valid_array_expn*/
  53. {
  54.     /* Called to validate indexing and slicing operations. The array name may
  55.      * be overloaded, and may also be an access to an array type. 
  56.      */
  57.  
  58.     Node    a_expn, i_node;
  59.     Set array_types, types, rset;
  60.     Tuple    index_list;
  61.     Node    index;
  62.     Symbol    n, a_t, t;
  63.     int        i, exists, forall;
  64.     Symbol    i_t;
  65.     Forset    fs1, fs2;
  66.     Fortup    ft1;
  67.  
  68.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  valid_array_expn");
  69.  
  70.     a_expn = N_AST1(expn);
  71.     i_node = N_AST2(expn);
  72.     resolve1(a_expn);
  73.     types = N_PTYPES(a_expn);
  74.     index_list = N_LIST(i_node);
  75.     array_types = set_new(0);    /* To collect valid types*/
  76.     FORTUP(index = (Node), index_list, ft1);
  77.         n = N_UNQ(index);
  78.         if (N_KIND(index) == as_simple_name && n != (Symbol)0 && is_type(n))
  79.             /* In the case of a slice, */
  80.             N_PTYPES(index) = set_new1((char *)TYPE_OF(n));
  81.             /* may be a type mark.*/
  82.         else
  83.             resolve1(index);
  84.     ENDFORTUP(ft1);
  85. #ifdef TBSN
  86.     if (cdebug2 > 3) TO_ERRFILE('index_list ' + str index_list);
  87. #endif
  88.     /* Now select those array types that are compatible with given indices.*/
  89.     FORSET(a_t = (Symbol), types, fs1);
  90.         t = a_t;
  91.         if (is_access(t)) {
  92.             if (is_fully_private(t)) {
  93.                 /* Cannot dereference an access to fully private type.*/
  94.                 if (set_size(array_types) == 1) {
  95.                     premature_access(t, a_expn);
  96.                     return set_new(0);
  97.                 }
  98.                 else
  99.                     continue;
  100.             }
  101.             else t = (Symbol) designated_type(t);
  102.         }
  103. #ifdef TBSN
  104.         if (cdebug2 > 3) {
  105.             TO_ERRFILE('type ' + str t);
  106.             TO_ERRFILE('# dims t ' + str no_dimensions(t));
  107.         }
  108. #endif
  109.         /* Discard incompatible array types */
  110.         if (!is_array(t) || no_dimensions(t) != tup_size(index_list))
  111.             continue;
  112.  
  113.         /* Now verify all indices in turn.*/
  114.         forall = TRUE;
  115.         FORTUPI(index = (Node), index_list, i, ft1);
  116.             exists = FALSE;
  117.             FORSET(i_t = (Symbol), N_PTYPES(index), fs2);
  118.                 if (compatible_types(i_t, (Symbol) index_types(t)[i])) {
  119.                     exists = TRUE;
  120.                     break;
  121.                 }
  122.             ENDFORSET(fs2);
  123.             if (exists == FALSE) {
  124.                 forall = FALSE;
  125.                 break;
  126.             }
  127.         ENDFORTUP(ft1);
  128.         if (forall)
  129.             /* a valid array type*/
  130.             array_types = set_with(array_types, (char *)a_t);
  131.     ENDFORSET(fs1);
  132. #ifdef TBSN
  133.     if (cdebug2 > 3) TO_ERRFILE('valid_array_expn ' + str array_types);
  134. #endif
  135.  
  136.     N_PTYPES(a_expn) = array_types;
  137.     rset = set_new(0);
  138.     FORSET(a_t = (Symbol), array_types, fs1);
  139.         if (is_access(a_t))
  140.             rset = set_with(rset, (char *) designated_type(a_t));
  141.         else
  142.             rset = set_with(rset, (char *) a_t);
  143.     ENDFORSET(fs1);
  144.     return rset;
  145. }
  146.  
  147. Symbol complete_array_expn(Node expn, Symbol c_type)  /*;complete_array_expn*/
  148. {
  149.     /* Called to complete the validation of an index or slice expression. The
  150.      * context type is the element    type for indexing, and the array type for
  151.      * slicing . The array expression may yield an access type, in which case
  152.      * a dereference operation is emitted now.
  153.      */
  154.  
  155.     Node    a_expn, index_list, a_node;
  156.     Set        array_types;
  157.     Symbol    array_type, a_t, t, c, access_type;
  158.     Forset    fs1;
  159.  
  160.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : complete_array_expn");
  161.  
  162.     a_expn = N_AST1(expn);
  163.     index_list = N_AST2(expn);
  164.     array_types = N_PTYPES(a_expn);
  165.     array_type = (Symbol)0;
  166.  
  167.     /* Iterate over array types to find unique one satisfying context.*/
  168.  
  169.     FORSET(a_t = (Symbol), array_types, fs1);
  170.         t = (is_access(a_t)) ? (Symbol)designated_type(a_t): a_t;
  171.         c = (N_KIND(expn) == as_slice) ? t: (Symbol) (component_type(t));
  172.         if (compatible_types(c_type, c)) {
  173.             if (array_type == (Symbol)0) {    /* One match found.*/
  174.                 array_type = t;
  175.                 access_type = a_t; /* Maybe an access.*/
  176.             }
  177.             else {
  178.                 /* If it is ambiguous, then it must an overloaded function*/
  179.                 /* that returns (an access to) an array.*/
  180.                 array_type = symbol_any;
  181.             }
  182.         }
  183.     ENDFORSET(fs1);
  184.     if (array_type == symbol_any) {
  185.         remove_conversions(a_expn);        /* last chance. */
  186.         if (set_size(N_PTYPES(a_expn)) == 1) {
  187.             array_type = (Symbol) set_arb(N_PTYPES(expn));
  188.             access_type = array_type;
  189.             if (is_access(array_type))
  190.                 array_type = (Symbol) designated_type(access_type);
  191.         }
  192.         else {        /* still ambiguous */
  193.             /* SETL sends {'indexing'}, in C, send {'any'} */
  194.             type_error(set_new1((char *) symbol_any), c_type, 
  195.               set_size(N_PTYPES(a_expn)), expn);
  196.         }
  197.     }
  198.     if (array_type == (Symbol)0) {
  199.         /* SETL sends {'indexing'}, in C, send {'any'} */
  200.         type_error(set_new1((char *) symbol_any), c_type, 
  201.           set_size(N_PTYPES(a_expn)), expn);
  202.         array_type = symbol_any;
  203.     }
  204.  
  205.     if (array_type != access_type) {           /* Insert dereference. */
  206.         a_node = copy_node(a_expn);
  207.         N_KIND(a_expn) = as_all;
  208.         N_AST1(a_expn) = a_node;
  209.         N_AST2(a_expn) = N_AST3(a_expn) = N_AST4(a_expn) = (Node) 0;
  210.         N_PTYPES(a_expn) = set_new1((char *) array_type);
  211.     }
  212.     resolve2(a_expn, array_type);            /* and resolve. */
  213.  
  214.     return array_type;
  215. }
  216.  
  217. void valid_selected_expn(Node expn) /*;valid_selected_expn*/
  218. {
  219.     /* Use the name of the selector to determine the possible types of obj,
  220.      * which may be a function returning (an access to) a record or task type
  221.      * The possible types of the expression are those of the selected comps.
  222.      */
  223.  
  224.     Node    obj, s_node;
  225.     Set types1, valid_t;
  226.     Symbol    o_t, t, comp;
  227.     char    *selector;
  228.     Forset    fs1;
  229.     Declaredmap    decls;
  230.  
  231.     obj = N_AST1(expn);
  232.     s_node = N_AST2(expn);
  233.     selector = N_VAL(s_node);
  234.     resolve1(obj);
  235.     types1 = N_PTYPES(obj);
  236.     valid_t = set_new(0);
  237.  
  238.     FORSET( o_t = (Symbol), types1, fs1);
  239.         t = o_t;
  240.         if (is_access(o_t))t = (Symbol) designated_type(o_t);
  241.         if (is_record(t))
  242.             decls = (Declaredmap) (declared_components(base_type(t)));
  243.         else if (is_task_type(t))
  244.             decls = DECLARED(t);
  245.         else continue;
  246.  
  247.         comp = dcl_get(decls, selector);
  248.         if (comp != (Symbol)0) {
  249.             if (is_access(o_t) && is_fully_private(o_t)
  250.               && NATURE(comp) != na_discriminant) { /*$ Can't dereference.*/
  251.                 if (set_size(types1) == 1) {
  252.                     premature_access(o_t, obj);
  253.                     return;
  254.                 }
  255.                 else continue;
  256.             }
  257.             else
  258.                 valid_t = set_with(valid_t, (char *) TYPE_OF(comp));
  259.         }
  260.     ENDFORSET(fs1);
  261.  
  262.     if (set_size(valid_t) == 0)
  263.         pass1_error("invalid selector name", "4.1.3", s_node);
  264.     N_PTYPES(expn) = valid_t;
  265. }
  266.  
  267. Symbol complete_selected_expn(Node expn, Symbol c_type)
  268.                                                     /*;complete_selected_expn*/
  269. {
  270.     /* Complete the resolution of a selected component  expression, by
  271.      * choosing the one that yields the context_type. If the type of the
  272.      * object selected from is an access type, emit a dereference.
  273.      */
  274.  
  275.     Node    obj, s_node, acc_obj;
  276.     Set types1;
  277.     Symbol    comp_t, o_t, t, comp, obj_t, c;
  278.     int        out_c;
  279.     Forset    fs1;
  280.     char    *selector;
  281.     Declaredmap    decls;
  282.  
  283.     obj = N_AST1(expn);
  284.     s_node = N_AST2(expn);
  285.     selector = N_VAL(s_node);
  286.     types1 = N_PTYPES(obj);
  287.     comp_t = (Symbol)0;
  288.     obj_t = symbol_any;
  289.  
  290.     FORSET( o_t = (Symbol), types1, fs1);
  291.         t = (is_access(o_t)) ? (Symbol) designated_type(o_t): o_t;
  292.     
  293.         if (is_record(t))
  294.             decls = (Declaredmap) declared_components(base_type(t));
  295.         else if (is_task_type(t))
  296.             decls = DECLARED(t);
  297.  
  298.         c = dcl_get(decls, selector);
  299.         if (c != (Symbol)0 && compatible_types(TYPE_OF(c), c_type)) {
  300.             comp = c;
  301.             if (comp_t == (Symbol)0) {
  302.                 comp_t = TYPE_OF(comp);        /* Found a match*/
  303.                 N_UNQ(s_node) = comp;
  304.                 obj_t = o_t;
  305.             }
  306.             else             /* ambiguous call to some*/
  307.                 obj_t = symbol_any;
  308.         }
  309.  
  310.     ENDFORSET(fs1); 
  311.  
  312.     if (obj_t == symbol_any) {
  313.         remove_conversions(obj);            /* last hope. */
  314.         if (set_size(N_PTYPES(obj)) != 1) {
  315. #ifdef TBSL
  316.             type_error(set_new1(symbol_selection), (Symbol)0, 
  317.               set_size(N_PTYPES(obj)), expn);
  318. #endif
  319.             return (Symbol)0;
  320.         }
  321.         else
  322.             obj_t = (Symbol) set_arb(N_PTYPES(obj));
  323.     }
  324.  
  325.     out_c = out_context;
  326.     /* This is a valid context for the use of an out parameter, if 
  327.      * it is an assigment to a component of it, or if it is a reading
  328.      * of a discriminant.
  329.      */
  330.     out_context = (out_c || NATURE(comp) == na_discriminant) ? TRUE:FALSE;
  331.  
  332.     if (is_access(obj_t)) {
  333.         obj_t = (Symbol) designated_type(obj_t);
  334.         /* Introduce explicit dereference. */
  335.         acc_obj = copy_node(obj);
  336.         N_KIND(obj) = as_all;
  337.         N_AST2(obj) = N_AST3(obj) = N_AST4(obj) = (Node) 0;
  338.         N_AST1(obj) = acc_obj;
  339.         N_PTYPES(obj) = set_new1((char *)obj_t);
  340.     }
  341.  
  342.     resolve2(obj, obj_t);
  343.     out_context = out_c;
  344.  
  345.     return comp_t;
  346. }
  347.  
  348. static Triplet *is_partition(Tuple choice_tuple, int choice_tuple_size,
  349.   int exist_other_choice)                                     /*;is_partition*/
  350. {
  351.  
  352.     /* Checks if the ranges of the choice_nodes in a named array aggregate form 
  353.      * a partition.
  354.      * For example: (1|2|4 =>2, 5..10 =>3, 3 =>2, NUM => 4) where you can find
  355.      * simple_choices, a range_choice and a choice_unresolved. This will be a
  356.      * partition if the type_mark NUM is disjoint with {1..10} assuming that 
  357.      * the bounds of the array are (1..NUM'LAST).  A range such as 7..4 is a
  358.      * null range. It is permitted only if alone in the array aggregate.
  359.      * This function returns a pointer to a Triplet. This Triplet gives the
  360.      * final range of the aggregate. Complete_a_aggregate checks after whether
  361.      * the range of the aggregate is the same than the range of the array. It
  362.      * uses the system call 'qsort' to sort the ranges by their lower bound
  363.      * and then uses this sorted list to verify that it is a partition.
  364.      */
  365.  
  366.     int        lbd, ubd = 0, ubd_save;
  367.     Triplet    *i_trip;
  368.     Node       choice;
  369.     int        i;
  370.  
  371.     if (choice_tuple_size != 0) {
  372.  
  373.         /*  1.  sort the set of choices giving a tuple  */
  374.  
  375.         choice_tuple = sort_case(choice_tuple);
  376.  
  377.         /*  2.  pass over choice_tuple checking that:
  378.          *        - there are only legal null ranges
  379.          *        - there are no overlapping ranges
  380.          *        - if the array aggregate does not have an others
  381.          *          then there are no missing associations
  382.          */
  383.  
  384.         for (i = 1; (i <= choice_tuple_size); i++) {
  385.             ubd_save = ubd;
  386.             lbd = ((Triplet *) choice_tuple[i])->inf;
  387.             ubd = ((Triplet *) choice_tuple[i])->sup;
  388.             choice = ((Triplet *) choice_tuple[i])->choice_node;
  389.  
  390.             /*  1.  Check for a null range. */
  391.             if ((lbd > ubd) && (choice_tuple_size > 1 || exist_other_choice)) {
  392.                 errmsg(
  393.                   "A null range in array aggregate must be the only choice",
  394.                   "4.3.2.(3)", choice);
  395.                 prev_error_message = 1;
  396.                 return (Triplet *)0;
  397.             }
  398.  
  399.             /*  2.  Check that the ranges do not overlap  */
  400.  
  401.             else if ((lbd <= ubd_save) && (i > 1)) {
  402.                 errmsg(
  403.                   "Component is not allowed to be specified more than once",
  404.                   "4.3.(6)", choice);
  405.                 prev_error_message = 1;
  406.                 return (Triplet *)0;
  407.             }
  408.  
  409.             /*  3.  Check that the intersection between the ranges is not null*/
  410.  
  411.             else if ((i > 1) && (!exist_other_choice) && (lbd != ubd_save+1)) {
  412.                 errmsg("Missing association in array aggregate", "4.3.(6)",
  413.                   choice);
  414.                 prev_error_message = 1;
  415.                 return (Triplet *)0;
  416.             }
  417.         }
  418.  
  419.         i_trip = triplet_new();
  420.         i_trip->inf = ((Triplet *) choice_tuple[1])->inf;
  421.         i_trip->sup = ((Triplet *) choice_tuple[choice_tuple_size])->sup;
  422.         return (i_trip);
  423.     }
  424. }
  425.  
  426. static Tuple sort_case(Tuple tuple_to_sort)                        /*;sort_case*/
  427. {
  428.     /*  This function sorts a tuple of triples based on the value of the
  429.      *  first element
  430.      */
  431.  
  432.     qsort((char *) &tuple_to_sort[1], tup_size(tuple_to_sort), sizeof (char *),
  433.       (int (*)(const void *, const void *))tcompar);
  434.     return tuple_to_sort;
  435. }
  436.  
  437. static int tcompar(Triplet **ptup1, Triplet **ptup2)            /*;tcompar*/
  438. {
  439.     Triplet  *tup1, *tup2;
  440.     int   n1, n2;
  441.  
  442.     tup1 = *ptup1;                 
  443.     tup2 = *ptup2;
  444.     n1 = (int) (tup1->inf);    
  445.     n2 = (int) (tup2->inf);
  446.     if (n1 == n2) return 0;
  447.     else if (n1 < n2) return -1;
  448.     else return 1;
  449. }
  450.  
  451. static int abs_val(int x)                                     /*;abs_val*/
  452. {
  453.     return (x >= 0) ? x : -x;
  454. }
  455.  
  456. void complete_aggregate(Symbol agg_type, Node expn)         /*;complete_aggregate*/
  457. {
  458.     /* Given the context type, resolve the aggregate components. For an array
  459.      * type we  pass index    and component  types separately     to the recursive
  460.      * routine complete_a_aggregate.  For record types  only the base type is
  461.      * needed here. Any required constraints are imposed in resolve2.
  462.      */
  463.  
  464.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : complete_aggregate");
  465.  
  466.     if (is_limited_type(agg_type)) {
  467.         errmsg_id("aggregates not available for limited type %", agg_type,
  468.           "7.4.4", expn);
  469.     }
  470.  
  471.     if (is_array(agg_type)) {
  472.         /* if the context allows sliding, the bounds of the aggregate need
  473.          * only be verified against the unconstrained type.              
  474.          */
  475.         if (full_others)
  476.             complete_a_aggregate(index_types(agg_type), index_types(agg_type),
  477.               component_type(agg_type), can_constrain(agg_type), expn);
  478.         else
  479.             complete_a_aggregate(index_types(agg_type),
  480.               index_types(TYPE_OF(agg_type)), component_type(agg_type),
  481.               can_constrain(agg_type), expn);
  482.     }
  483.     else if (is_record(agg_type))
  484.         complete_r_aggregate(base_type(agg_type), expn);
  485.     else {
  486.         errmsg("Invalid context for aggregate", "none", expn);
  487.     }
  488. }
  489.  
  490. static void complete_a_aggregate(Tuple indices, Tuple base_indices,
  491.   Symbol comp_type, int is_unc, Node expn)            /*;complete_a_aggregate*/
  492. {
  493.     /* Complete processing of an array aggregate. The tree is normalized as
  494.      * follows:
  495.      *     N_KIND = as_array_aggregate
  496.      *     N_AST = [list_node, others_node]
  497.      * where list_node has two entries:
  498.      *     N_AST = [pos_list, nam_list]
  499.      * The first two are list nodes. The elements of N_LIST(nam_list) are
  500.      * pairs [choice_list, expression].  The N_KIND of choice nodes are 
  501.      * as_simple_choice and as_range_choice.  A simple_choice includes a 
  502.      * type name specifiying a range.
  503.      */
  504.  
  505.     Tuple    arg_list, pos_list, nam_list, tup, b_itup, itup;
  506.     Node    others_node, last_arg, choice_list, c_expr, lexpn;
  507.     Node    arg, i_expr, range_constraint, choice, pos_node, nam_node;
  508.     Symbol    type_mark, indxt, b_indxt;
  509.     Fortup    ft1, ft2;
  510.     int    i, n, nn;
  511.     int     c_ind, exist_other_choice, lbd, ubd, lbd_val, ubd_val;
  512.     int     static_test, choice_tuple_size;
  513.     int    raises;
  514.     Tuple   choice_tuple;
  515.     Triplet    *aggr_range;
  516.     Node    lw_bd, hg_bd, lo_bd, up_bd, simple_expr1, simple_expr2;
  517.     char    *nchoice;
  518.  
  519.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : complete_a_aggregate");
  520.  
  521.     arg_list = N_LIST(expn);
  522.     b_indxt = (Symbol) base_indices[1];
  523.     indxt = (Symbol) indices[1];
  524.     others_node = OPT_NODE;
  525.     pos_list = tup_new(0);
  526.     nam_list = tup_new(0);
  527.     choice_tuple_size = 0;
  528.     static_test = 1;
  529.     c_ind = 1;
  530.     exist_other_choice = 0;
  531.     prev_error_message = 0;
  532.     raises = FALSE;
  533.  
  534.     /* STEP 1.
  535.      *   Remove the OTHERS choice from the arggregate list if it is the last
  536.      *   component and place in -others_choice-. Otherwise if it appears
  537.      *   elsewhere in the aggregate it will be noted as a error later.
  538.      */
  539.  
  540.     last_arg = (Node) arg_list[tup_size(arg_list)];
  541.     if (N_KIND(last_arg) == as_choice_list) {
  542.         choice_list = N_AST1(last_arg);
  543.         c_expr = N_AST2(last_arg);
  544.         tup = N_LIST(choice_list);
  545.         choice = (Node) tup[1];
  546.  
  547.         if (N_KIND(choice) == as_others_choice) {
  548.             exist_other_choice = 1;
  549.             others_node = c_expr;
  550.  
  551.             if (is_unc || (!is_static_subtype(indxt) && tup_size(arg_list)>1)) {
  552.                 errmsg("OTHERS choice not allowed in this context", "4.3.2",
  553.                   last_arg);
  554.             }    /* process anyway*/
  555.  
  556.             tup_frome(arg_list);
  557.             resolve1(c_expr);
  558.             n = tup_size(base_indices);
  559.             nn = tup_size(indices);
  560.             if (nn > 0 && n > 0) {
  561.                 b_itup = tup_new(n-1);
  562.                 itup = tup_new(n-1);
  563.                 for (i = 1; i < n; i++)
  564.                     b_itup[i] = base_indices[i+1];
  565.                 for (i = 1; i < nn; i++)
  566.                     itup[i] = indices[i+1];
  567.                 complete_component(itup, b_itup, comp_type, is_unc, c_expr);
  568.                 raises = raises || (N_KIND(c_expr) == as_raise);
  569.             }
  570.         }
  571.     }
  572.  
  573.     /* STEP 2.
  574.      *   After any others clause has been processed, process the named and
  575.      *   positional associations
  576.      */
  577.  
  578.     FORTUP(arg = (Node), arg_list, ft1);
  579.         if (N_KIND(arg) == as_choice_list) {
  580.             /* STEP 2a.
  581.              *   Process named association choice list 
  582.              */
  583.             choice_list = N_AST1(arg);
  584.             c_expr = N_AST2(arg);
  585.             resolve1(c_expr);
  586.             n = tup_size(base_indices);
  587.             nn = tup_size(indices);
  588.             if (nn > 0 && n > 0) {
  589.                 b_itup = tup_new(n-1);
  590.                 itup = tup_new(n-1);
  591.                 for (i = 1; i < n; i++)
  592.                     b_itup[i] = base_indices[i+1];
  593.                 for (i = 1; i < nn; i++)
  594.                     itup[i] = indices[i+1];
  595.                 complete_component(itup, b_itup, comp_type, is_unc, c_expr);
  596.                 raises = raises || (N_KIND(c_expr) == as_raise);
  597.             }
  598.             else
  599.                 chaos("complete_a_aggregate - indices null");
  600.             /* STEP 2b.
  601.              *   Process each choice in the choice list
  602.              */
  603.             FORTUP(choice = (Node), N_LIST(choice_list), ft2);
  604.                 n = -1;
  605.                 if (N_KIND(choice) == as_choice_unresolved) {
  606.                     /* Case:  choice_unresolved:
  607.                      *     If the index expression is an identifier, it must be
  608.                      *     a type name or an object.
  609.                      */
  610.                     i_expr = N_AST1(choice);
  611.                     find_old(i_expr);
  612.                     type_mark = N_UNQ(i_expr);
  613.                     if (is_type(type_mark)) {
  614.                         /* Subcase: type type_mark of choice_unresolved
  615.                          *   check that it is either the only choice -or- is
  616.                          *   static...
  617.                          *     set the N_KIND to a as_simple_name
  618.                          *     check that the type_mark is compatible with
  619.                          *     the base index type 
  620.                          */
  621.                         tup = SIGNATURE(type_mark);
  622.                         lo_bd = (Node) tup[2];
  623.                         up_bd = (Node) tup[3];
  624.                         if ((!is_static_expr(lo_bd))||(!is_static_expr(up_bd))){
  625.                             if ((tup_size(arg_list)>1) || exist_other_choice) {
  626.                                 errmsg(
  627.     "Non static choice in array aggregate must be the only choice",
  628.     "4.3.2.(3)", choice); 
  629.                             }
  630.                             static_test = 0;
  631.                         }
  632.                         else {
  633.                             lbd_val = INTV((Const) N_VAL(lo_bd));
  634.                             ubd_val = INTV((Const) N_VAL(up_bd));
  635.                         }
  636.                         N_KIND(choice) = as_simple_name;
  637.                         nchoice = N_VAL(choice); /* preserve N_VAL */
  638.                         N_AST1(choice) = (Node)0;
  639.                         N_AST2(choice) = (Node)0;
  640.                         N_AST3(choice) = (Node)0;
  641.                         N_AST4(choice) = (Node)0;
  642.                         N_UNQ(choice) = type_mark;
  643.                         N_VAL(choice) = nchoice; /* preserve N_VAL */
  644.                         if (!compatible_types(type_mark, b_indxt)) {
  645.                             errmsg("invalid type mark in array aggregate",
  646.                               "4.3", choice);
  647.                             return;
  648.                         }
  649.                     }
  650.                     else { /* single association*/
  651.                         /* Subcase: simple_choice of choice_unresolved
  652.                          *     this is a single association
  653.                          *     set the N_KIND to a as_simple_name check that
  654.                          *     it is either the only choice -or- is static...
  655.                          */
  656.                         N_KIND(choice) = as_simple_choice;
  657.                         i_expr = N_AST1(choice);
  658.                         check_type(base_type(b_indxt), i_expr);
  659.                         if (N_TYPE(i_expr) == symbol_any)
  660.                             static_test = 0;
  661.                         else if (!is_static_expr(i_expr)) {
  662.                             if ((tup_size(arg_list)>1) || exist_other_choice) {
  663.                                 errmsg(
  664.     "Non static choice in array aggregate must be the only choice", "4.3.2.(3)",
  665.     choice);
  666.                             }
  667.                             static_test = 0;
  668.                         }
  669.                         else {
  670.                             lbd_val = INTV((Const) N_VAL(i_expr));
  671.                             ubd_val = INTV((Const) N_VAL(i_expr));
  672.                         }
  673.                     }
  674.                 }
  675.                 /* Case: as_simple_choice
  676.                  *   The association is known to be a simple expression.
  677.                  *     check that the type of the expression 
  678.                  *     check that it is either the only choice -or- is static...
  679.                  */
  680.                 else if (N_KIND(choice) == as_simple_choice) {
  681.                     i_expr = N_AST1(choice);
  682.                     adasem(i_expr);
  683.                     check_type(base_type(b_indxt), i_expr);
  684.                     if (N_TYPE(i_expr) == symbol_any)
  685.                         static_test = 0;
  686.                     else if (!is_static_expr(i_expr)) {
  687.                         if ((tup_size(arg_list) > 1) || exist_other_choice)   {
  688.                             errmsg(
  689.     "Non static choice in array aggregate must be the only choice",
  690.     "4.3.2.(3)", choice);
  691.                         }
  692.                         static_test = 0;
  693.                     }
  694.                     else {
  695.                         lbd_val = INTV((Const) N_VAL(i_expr));
  696.                         ubd_val = INTV((Const) N_VAL(i_expr));
  697.                     }
  698.                 }
  699.                 /* Case: range_choice
  700.                  */
  701.                 else if (N_KIND(choice) == as_range_choice) {
  702.                     i_expr = N_AST1(choice);
  703.                     check_type(b_indxt, i_expr);
  704.                     if (N_KIND(i_expr) == as_subtype) {
  705.                         /* Subcase: expression is subtype in range_choice
  706.                          *   Extract the constraint itself is static, reformat
  707.                          *   choice as range else check that it is the only
  708.                          *   choice
  709.                          */
  710.                         range_constraint = N_AST2(i_expr);
  711.                         copy_attributes(range_constraint, choice);
  712.                         simple_expr1 = N_AST1(range_constraint);
  713.                         simple_expr2 = N_AST2(range_constraint);
  714.                         if (N_TYPE(i_expr) == symbol_any)
  715.                             static_test = 0;
  716.                         else if ((!is_static_expr(simple_expr1))
  717.                           || (!is_static_expr(simple_expr2))) {
  718.                             if ((tup_size(arg_list) > 1) || exist_other_choice){
  719.                                 errmsg(
  720.     "Non static choice in array aggregate must be the only choice",
  721.     "4.3.2.(3)", choice);
  722.                             }
  723.                             static_test = 0;
  724.                         }
  725.                         else {
  726.                             lbd_val = INTV((Const) N_VAL(simple_expr1));
  727.                             ubd_val = INTV((Const) N_VAL(simple_expr2));
  728.                         }
  729.                     }
  730.                     else { /*attribute RANGE.*/
  731.                         /* Subcase: attribute range subtype in range_choice
  732.                          *        this means that it is an attrtibute range
  733.                          */
  734.                         static_test = 0;
  735.                     }
  736.                 }
  737.                 /* Case: others choice (illegal at this point)
  738.                  */
  739.  
  740.                 else if (N_KIND(choice) == as_others_choice)  {
  741.                     errmsg("OTHERS must be the last aggregate component",
  742.                       "4.3", choice);
  743.                     return;
  744.  
  745.                 }
  746.                 /* STEP 2c.
  747.                  *   After processing the choice if it is static then add to
  748.                  *   choice list to be tested with is_partition
  749.                  */
  750.                 if (static_test) {
  751.                     aggr_range = triplet_new();
  752.                     aggr_range->inf = lbd_val;  /*bounds and node of the curr */
  753.                     aggr_range->sup = ubd_val;  /*choice_node for is_partition*/
  754.                     aggr_range->choice_node = choice;
  755.                     if (c_ind == 1)
  756.                         choice_tuple = tup_new1((char *) aggr_range);
  757.                     else
  758.                         choice_tuple =tup_with(choice_tuple,(char *)aggr_range);
  759.                 }
  760.                 c_ind++;
  761.             ENDFORTUP(ft2);   /* choice within a named choice list */
  762.  
  763.             /* STEP 2d.
  764.              *    Add the choice list to the tuple of named associations
  765.              */
  766.             nam_list = tup_with(nam_list, (char *) arg);
  767.         }
  768.  
  769.         /* STEP 3.
  770.          *   Process positional components...
  771.          */
  772.         else { /* Positional component. */
  773.             resolve1(arg);
  774.             n = tup_size(base_indices);
  775.             nn = tup_size(indices);
  776.             if (nn > 0 && n > 0) {
  777.                 b_itup = tup_new(n-1);
  778.                 itup = tup_new(n-1);
  779.                 for (i = 1; i < n; i++)
  780.                     b_itup[i] = base_indices[i+1];
  781.                 for (i = 1; i < nn; i++)
  782.                     itup[i] = indices[i+1];
  783.                 complete_component(itup, b_itup, comp_type, is_unc, arg);
  784.                 raises = raises || (N_KIND(arg) == as_raise);
  785.             }
  786.             else chaos("complete_a_aggregate - indices null");
  787.             pos_list = tup_with(pos_list, (char *) arg);
  788.         }
  789.     ENDFORTUP(ft1); /* end of processing the choice lists  */
  790.  
  791.     /* STEP 4.
  792.      *   Perform the final checks.  
  793.      *     A. Check that either the name list or the position list is null
  794.      *     B. Check for valid context for Others choice
  795.      */
  796.     if (tup_size(pos_list) > 0 && tup_size(nam_list) > 0) {
  797.         errmsg_l("In a positional aggregate only named association ",
  798.           "allowed is OTHERS", "4.3.2", expn);
  799.         return;
  800.     }
  801.     else if (others_node != OPT_NODE && !full_others && tup_size(nam_list) !=0){
  802.         errmsg("Invalid context for OTHERS and named associations",
  803.           "4.3.2(6)", others_node);
  804.         return;
  805.     }
  806.  
  807.     tup = SIGNATURE(indxt);   /*range of the array.*/
  808.     lw_bd = (Node) tup[2];
  809.     hg_bd = (Node) tup[3];
  810.     /* STEP 5.
  811.      *   Perform check is it is static and named
  812.      *   If it is a partition then check:
  813.      *     A.  If the range is out of bounds (base index) considering sliding
  814.      *     B.  if the size of the choice range is less than the index range
  815.      *     C.  if the size of the choice range is greater that the index range
  816.      *     D.  if the choice range is null and the index range is not
  817.      */
  818.     if (n == -1 && static_test)   {
  819.         choice_tuple_size = tup_size(choice_tuple);
  820.         aggr_range = is_partition(choice_tuple, choice_tuple_size,
  821.           exist_other_choice);
  822.  
  823.         if (!prev_error_message && !exist_other_choice)  {
  824.             lbd = aggr_range->inf;
  825.             ubd = aggr_range->sup;
  826.             tup = SIGNATURE(b_indxt); /*range of the indices.*/
  827.             lo_bd = (Node) tup[2];
  828.             up_bd = (Node) tup[3];
  829.             if ((is_static_expr(lo_bd)) && (is_static_expr(up_bd)))  {
  830.                 lbd_val = INTV((Const) N_VAL(lo_bd));
  831.                 ubd_val = INTV((Const) N_VAL(up_bd));
  832.  
  833.                 /* Check A */
  834.                 if ((lbd_val > lbd || ubd_val < ubd)
  835.                   && (ubd_val > lbd_val && ubd > lbd)   /*Non-null range*/
  836.                   && full_others)   {
  837.                     /* Does not check anything if the subtype_range or the
  838.                      * aggregate_range is null, according to test c43206a.
  839.                      */
  840.                     raises = TRUE;
  841.                 }
  842.             }
  843.             if (!is_unc) {
  844.                 if ((is_static_expr(lw_bd)) && (is_static_expr(hg_bd)))  {
  845.                     lbd_val = INTV((Const) N_VAL(lw_bd));
  846.                     ubd_val = INTV((Const) N_VAL(hg_bd));
  847.                     /* TBSL : ubd_val-lbd_val may be superior to INTEGER'LAST.
  848.                      * Use multiprecision.
  849.                      */
  850.                     /* Check B */
  851.                     if ((ubd_val > lbd_val && ubd > lbd)   /*Non-null range*/
  852.                       && (abs_val(ubd_val - lbd_val) < abs_val(ubd - lbd)))
  853.                         raises = TRUE;
  854.                     /* TBSL : ubd_val-lbd_val may be superior to INTEGER'LAST.
  855.                      * Use multiprecision.
  856.                      */
  857.                     /* Check C */
  858.                     else if ((ubd_val > lbd_val && ubd > lbd) /*Non-null range*/
  859.                       && (abs_val(ubd_val - lbd_val) > abs_val(ubd - lbd))) {
  860.                         /* CONSTRAINT_ERROR may be raised according to test
  861.                          * c48009f instead of:
  862.                            *     errmsg("Missing association in array aggregate",
  863.                          *       "4.3.(6)", expn);
  864.                          */
  865.                         raises = TRUE;
  866.                     }
  867.                     /* Check D */
  868.                     else if (ubd_val < lbd_val && ubd > lbd) {
  869.                         raises = TRUE;
  870.                     }
  871.                 }
  872.             }
  873.         }
  874.     }
  875.     /* STEP 6.
  876.      *   Perform check is it is position, not others and unconstrained
  877.      */
  878.     if (n != -1 && !is_unc && !exist_other_choice) { /*Positional components*/
  879.         if ((is_static_expr(lw_bd)) && (is_static_expr(hg_bd)))  {
  880.             lbd_val = INTV((Const) N_VAL(lw_bd));
  881.             ubd_val = INTV((Const) N_VAL(hg_bd));
  882.             /* TBSL : ubd_val-lbd_val may be superior to INTEGER'LAST.
  883.              * Use multiprecision.
  884.              */
  885.             if (tup_size(pos_list) != abs_val(ubd_val-lbd_val) + 1) {
  886.                 raises = TRUE;
  887.             }
  888.         }
  889.     }
  890.  
  891.     /* STEP 7. 
  892.      *   Proccess an others choice by itself by converted into a named
  893.      *   association
  894.      */
  895.     if (tup_size(pos_list) == 0 && tup_size(nam_list) == 0) {
  896.         if ((N_KIND(lw_bd) == as_ivalue || N_KIND(lw_bd) == as_discr_ref)
  897.           &&  (N_KIND(hg_bd) == as_ivalue || N_KIND(hg_bd) == as_discr_ref)) {
  898.             choice = node_new(as_range);
  899.             N_AST1(choice) = copy_tree(lw_bd);
  900.             N_AST2(choice) = copy_tree(hg_bd);
  901.             arg = node_new(as_choice_list);
  902.             N_AST1(arg) = node_new(as_list);
  903.             N_LIST(N_AST1(arg)) = tup_new1( (char *)choice);
  904.             N_AST2(arg) = others_node;
  905.             nam_list = tup_new1( (char *)arg);
  906.             others_node = OPT_NODE;
  907.         }
  908.     }
  909.  
  910.     /* If any component or subaggregate raises constraint error, replace the
  911.      * whole aggregate by a raise node.
  912.      */
  913.     if (raises) {
  914.         create_raise(expn, symbol_constraint_error);
  915.         return;
  916.     }
  917.     /* STEP 8. 
  918.      *   Create the pos and name lists nodes
  919.      */
  920.     pos_node = node_new(as_list);
  921.     nam_node = node_new(as_list);
  922.     N_LIST(pos_node) = pos_list;
  923.     N_LIST(nam_node) = nam_list;
  924.  
  925.     N_KIND(expn) = as_array_aggregate;
  926.     N_UNQ(expn) = sym_new(na_void);
  927.     N_LIST(expn) = tup_new(0);    /* no further need for it.*/
  928.     lexpn = node_new(as_aggregate_list);
  929.     N_AST1(lexpn) = pos_node;
  930.     N_AST2(lexpn) = nam_node;
  931.     N_AST1(expn) = lexpn;
  932.     N_AST2(expn) = others_node;
  933.     N_AST4(expn) = (Node) 0;
  934. }
  935.  
  936. static void complete_component(Tuple indices, Tuple b_indices, Symbol comp_type,
  937.    int is_unc, Node expn)                                /*;complete_component*/
  938. {
  939.     /* Complete the     resolution of a component of  an array aggregate. If it
  940.      * is a multidimensional aggregate, the component itself is an array and
  941.      * a recursive    call is made with the remaining indices. String literals
  942.      * are handled in their own routine.
  943.      */
  944.  
  945.     Node    expn2;
  946.  
  947.     if (cdebug2 > 3) TO_ERRFILE("AT PROC complete_component");
  948.  
  949.     if (tup_size(b_indices) == 0)
  950.         res2_check(expn, comp_type);
  951.     else if (N_KIND(expn) == as_aggregate)
  952.         complete_a_aggregate(indices, b_indices, comp_type, is_unc, expn);
  953.     else if (N_KIND(expn) == as_string_literal) {
  954.         if (tup_size(b_indices) != 1) {
  955.             errmsg("Invalid use of literal in aggregate", "4.3.2", expn);
  956.             return;
  957.         }
  958.         complete_string_literal(expn, comp_type);
  959.         N_TYPE(expn) = (Symbol) 0; /* clear as no type defined here */
  960.     }
  961.     else if (N_KIND(expn) == as_parenthesis) {
  962.         /* Context of subaggregate is unconstrained, "others" choice is not*/
  963.         /* allowed.*/
  964.         expn2 = N_AST1(expn);
  965.         complete_component(indices, b_indices, comp_type, TRUE, expn2);
  966.     }
  967.     else {
  968.         errmsg("Expect aggregate for component of multidimensional aggregate",
  969.           "4.3.2", expn);
  970.     }
  971. }
  972.  
  973. void complete_string_literal(Node node, Symbol comp)
  974.                                                 /*;complete_string_literal*/
  975. {
  976.     /* String literals can appear as aggregates for arrays of character type.
  977.      * We have to verify that each character in the string is an  enumeration
  978.      * literal for that type.
  979.      */
  980.  
  981.     char    *strg, c, *lit;
  982.     Tuple    arr, lit_map;
  983.     Node    lo, hi;
  984.     Symbol    sc;
  985.     int        i, strglen, istr, ilitmap, v, exists, found;
  986.  
  987.     strg = N_VAL(node);
  988.     sc = SCOPE_OF(comp);
  989.     if (!tup_mem((char *)sc, open_scopes) && !tup_mem((char *)sc, used_mods)) {
  990.         errmsg("characters in a string literal must be directly visible",
  991.          "4.2(3)", node);
  992.     }
  993.  
  994.     if (comp == symbol_character || comp == symbol_any) {
  995.         /*arr := [abs c: c in strg];*/
  996.         strglen = strlen(strg);
  997.         arr = tup_new(strglen);
  998.         for (i = 1; i <= strglen; i++)
  999.             arr[i] = (char *) strg[i-1];
  1000.         N_VAL(node) = (char *) arr;
  1001.         N_KIND(node) = as_string_ivalue;
  1002.     }
  1003.     else {/* Some enumeration type. Use its literal map.*/
  1004.         if (NATURE(base_type(comp)) != na_enum) {
  1005.             errmsg("Component type of context is not a character type",
  1006.               "4.2", node);
  1007.             return;
  1008.         }
  1009.         lit_map = (Tuple) literal_map(base_type(comp));
  1010.         if (lit_map == (Tuple)0) lit_map = tup_new(0);
  1011.         /* arr := [lit_map('''' + c + '''') : c in strg]; */
  1012.         strglen = strlen(strg);
  1013.         arr = tup_new(strglen);
  1014.         lit = emalloct(4, "complete-string-literal");
  1015.         exists = FALSE;
  1016.         for (istr = 0; c = strg[istr]; istr++) {
  1017.             lit[0] = lit[2] = '\'';
  1018.             lit[1] = c;
  1019.             lit[3] = '\0';
  1020.             found = FALSE;
  1021.             for (ilitmap = 1; ilitmap < tup_size(lit_map); ilitmap += 2) {
  1022.                 if (streq(lit, lit_map[ilitmap])) {
  1023.                     arr[istr+1] = lit_map[ilitmap+1];
  1024.                     found = TRUE;
  1025.                     break;
  1026.                 }
  1027.             }
  1028.             if (!found)
  1029.                 exists = TRUE;
  1030.         }
  1031.         /* if exists c = strg(i) | arr(i) = om then */
  1032.         /*  Some characters are not in the component type. */
  1033.         if (exists) {
  1034.             create_raise(node, symbol_constraint_error);
  1035.             return;
  1036.         }
  1037.         else {
  1038.             /* The individual characters must be bounds-checked as any other
  1039.              * array component.
  1040.              */
  1041.             N_VAL(node) = (char *)arr;
  1042.             N_KIND(node) = as_string_ivalue;
  1043.             if (NATURE(comp) == na_subtype) {
  1044.                 lo = (Node) (SIGNATURE(comp))[2];
  1045.                 hi = (Node) (SIGNATURE(comp))[3];
  1046.                 if (is_static_expr(lo) && is_static_expr(hi)) {
  1047.                     /* and exists v in arr | v<N_VAL(lo) or v>N_VAL(hi) then */
  1048.                     for (istr = 1; istr <= strglen; istr++) {
  1049.                         v = (int) arr[istr];
  1050.                         if (v < ((Const)N_VAL(lo))->const_value.const_int
  1051.                           || v > ((Const)N_VAL(hi))->const_value.const_int) {
  1052.                             create_raise(node, symbol_constraint_error);
  1053.                             return;
  1054.                         }
  1055.                     }
  1056.                 }
  1057.             }
  1058.         }
  1059.     }
  1060. }
  1061.  
  1062. void complete_r_aggregate(Symbol aggregate_type, Node expn)
  1063.                                                     /*;complete_r_aggregate*/
  1064. {
  1065.     /* Perform resolution of components in a record aggregate. If the
  1066.      * record type has discriminants, we must first resolve the discriminant
  1067.      * components, in order to determine the variant parts to which the rest
  1068.      * of the aggregate must conform.
  1069.      */
  1070.  
  1071.     Tuple    arg_list, ttup, btup;
  1072.     Tuple    discr_list;
  1073.     int        first_named, exists, ctupi, num_discr;
  1074.     Tuple    positional_args;
  1075.     Tuple    named_args;
  1076.     int        discri;
  1077.     Node    comp_assoc, choice_list, choice_node, e, c_expr, others_expr;
  1078.     Tuple    discr_map, all_component_names;
  1079.     int i1, found_discr_val;
  1080.     char    *sel;
  1081.     Node    simple_name, others_comp_list, lnode;
  1082.     Symbol    discr, bs, ctupd, btype;
  1083.     Node    invariant_node, variant_node, ctupn;
  1084.     Declaredmap    sel_names;
  1085.     Tuple    leftovers;
  1086.     Node    discr_id, variant_list, alt;
  1087.     int        discr_value, lo, hi;
  1088.     Tuple    case_list;
  1089.     Node    case_node, component_list, list_node;
  1090.     Tuple    comp_assoc_list;
  1091.     int        comp_pos, i, j, k;
  1092.     Tuple    choices, components_seen;
  1093.     /*    sel                : IDENTIFIER;*/
  1094.     Symbol    selector;
  1095.     Fortup    ft1, ft2;
  1096.     int    found_discr_value;
  1097.  
  1098.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : complete_r_aggregate:");
  1099.  
  1100.     /* In SETL, components_seen is a set of symbols. Here we keep it as
  1101.      * tuple. Since it is a local variable, we allocate it here and free
  1102.      * it before every return from this procedure.
  1103.      */
  1104.     components_seen = tup_new(0);
  1105.     arg_list = N_LIST(expn);
  1106.     discr_list = (Tuple) discriminant_list(aggregate_type);
  1107.     num_discr = tup_size(discr_list);
  1108.     /* Components can be given by named choices. Divide argument list
  1109.      * into positional and named components .
  1110.      */
  1111.     exists = FALSE;
  1112.     FORTUPI(comp_assoc = (Node), arg_list, i, ft1);
  1113.         if (N_KIND(comp_assoc) == as_choice_list) {
  1114.             exists = TRUE;
  1115.             break;
  1116.         }
  1117.     ENDFORTUP(ft1);
  1118.     if (exists)
  1119.         first_named = i;
  1120.     else
  1121.         first_named = tup_size(arg_list) + 1;
  1122.  
  1123.     /* TBSL: positional_args and named_args may not have to be built
  1124.      * as separate tuples; if they are, should free on return
  1125.      * Also check that don't get into nasty boundary cases here
  1126.      * (building tuple of length -1, etc.
  1127.      */
  1128.     positional_args = tup_new(first_named-1);
  1129.     for (j = 1; j <= first_named-1; j++)
  1130.         positional_args[j] = arg_list[j];
  1131.     /*named_args = arg_list(first_named..);*/
  1132.     named_args = tup_new(tup_size(arg_list)-first_named+1);
  1133.     k = 1;
  1134.     for (j = first_named; j <= tup_size(arg_list); j++)
  1135.         named_args[k++] = arg_list[j];
  1136.     others_expr = (Node) 0;
  1137.     FORTUP(comp_assoc = (Node), named_args, ft1);
  1138.         choice_list = N_AST1(comp_assoc);
  1139.         c_expr = N_AST2(comp_assoc);
  1140.         exists = FALSE;
  1141.         FORTUP(choice_node = (Node), N_LIST(choice_list), ft2);
  1142.             if (N_KIND(choice_node) == as_others_choice) {
  1143.                 exists = TRUE;
  1144.                 break;
  1145.             }
  1146.         ENDFORTUP(ft2);
  1147.         if (exists) {
  1148.             if (tup_size( N_LIST(choice_list)) != 1
  1149.               || (comp_assoc != (Node)named_args[tup_size(named_args)])) {
  1150.                 errmsg("OTHERS must appear alone and last in a choice list",
  1151.                   "4.3", choice_node);
  1152.                 tup_free(components_seen);
  1153.                 return;
  1154.             }
  1155.             else {
  1156.                 others_expr = c_expr;
  1157.                 break;
  1158.             }
  1159.         }
  1160.     ENDFORTUP(ft1);
  1161.  
  1162.     discr_map = tup_new(0);
  1163.     if (num_discr > 0) {
  1164.         /* add value for 'constrained' bit, and do not check for it later.*/
  1165.         e = new_ivalue_node(int_const(TRUE), symbol_boolean);
  1166.         copy_span((Node)arg_list[1], e);
  1167.         discr_map = discr_map_put(discr_map, symbol_constrained, e);
  1168.     }
  1169.     /* Map the discriminants into the (hopefully) static expressions
  1170.      * given for them. Omit constrained bit from consideration.
  1171.      */
  1172.     i1 = num_discr == 0 ? 0:
  1173.       (num_discr -1 < tup_size(positional_args) ? num_discr -1 : 
  1174.       tup_size(positional_args));
  1175.     /* collect the positional discriminants first. */
  1176.     for (i = 1; i <= i1; i++) {
  1177.         comp_assoc = (Node) positional_args[i];
  1178.         discr_map =
  1179.           discr_map_put(discr_map, (Symbol) discr_list[i+1], comp_assoc);
  1180.     }
  1181.     /* Now look for named discriminants among named components.*/
  1182.  
  1183.     for (i = i1 + 2; i <= num_discr; i++) {
  1184.         discr = (Symbol) (discr_list[i]);
  1185.  
  1186.         found_discr_val = FALSE;
  1187.         FORTUP(comp_assoc = (Node), named_args, ft1);
  1188.             choice_list = N_AST1(comp_assoc);
  1189.             c_expr = N_AST2(comp_assoc);
  1190.             FORTUP(choice_node = (Node), N_LIST(choice_list), ft2);
  1191.                 if (N_KIND(choice_node) == as_choice_unresolved) {
  1192.                     simple_name = N_AST1(choice_node);
  1193.                     if (streq(N_VAL(simple_name), original_name(discr))) {
  1194.                         found_discr_val = TRUE;
  1195.                         goto endforcomp;
  1196.                     }
  1197.                 }
  1198.             ENDFORTUP(ft2);
  1199.         ENDFORTUP(ft1);
  1200. endforcomp:
  1201.         if (found_discr_val)
  1202.             discr_map = discr_map_put(discr_map, discr, c_expr);
  1203.         else if (others_expr != (Node)0)
  1204.             discr_map = discr_map_put(discr_map, discr,
  1205.               copy_tree(others_expr));
  1206.         else {
  1207.             errmsg_id("No value supplied for discriminant %", discr,
  1208.               "4.3.1", expn);
  1209.             tup_free(components_seen);
  1210.             return;
  1211.         }
  1212.     }
  1213.     /* perform type resolution on the associations for discriminants */
  1214.     for (discri = 1; discri <= tup_size(discr_map); discri += 2) {
  1215.         discr = (Symbol) discr_map[discri];
  1216.         c_expr = (Node) discr_map[discri+1];
  1217.         if (N_TYPE(c_expr) == (Symbol)0)
  1218.             check_type(TYPE_OF(discr), c_expr);
  1219.     }
  1220.     invariant_node = (Node) invariant_part(aggregate_type);
  1221.     variant_node = (Node)(variant_part(aggregate_type));
  1222.     sel_names = (Declaredmap) declared_components(aggregate_type);
  1223.     /* Now assemble the list of selector names. Each component declara-
  1224.      * tion declares a list of selectors with the same type.
  1225.      */
  1226.     all_component_names = build_comp_names(invariant_node);
  1227.     /* Scan the variant part of the record declaration, and collect the
  1228.      * types corresponding to the given discriminants.
  1229.      */
  1230.     while (variant_node != OPT_NODE) {
  1231.         found_discr_value = FALSE;
  1232.         discr_id = N_AST1(variant_node);
  1233.         variant_list = N_AST2(variant_node);
  1234.         c_expr = discr_map_get(discr_map, N_UNQ(discr_id));
  1235.         /* Verify that a discriminant which governs a variant part*/
  1236.         /* is static.*/
  1237.         if (!is_static_expr(c_expr)) {
  1238.             errmsg_nval("Value for discriminant % must be static", discr_id,
  1239.               "4.3.1", c_expr);
  1240.             /* TBSL: this was N_UNQ, but probably should be N_VAL (gs Sep 20)*/
  1241.             tup_free(components_seen);
  1242.             return;
  1243.         }
  1244.  
  1245.         discr_value = INTV((Const)N_VAL(c_expr));
  1246.         case_list = N_LIST(variant_list);
  1247.         case_node = (Node)case_list[tup_size(case_list)];
  1248.         if (N_KIND(case_node) == as_others_choice)
  1249.             others_comp_list = N_AST2(case_node);
  1250.         else
  1251.             others_comp_list = (Node)0;
  1252.         FORTUP(case_node = (Node), case_list, ft1);
  1253.             choice_list = N_AST1(case_node);
  1254.             component_list = N_AST2(case_node);
  1255.             exists = FALSE;
  1256.             if (N_KIND(case_node) == as_others_choice) continue;
  1257.  
  1258.             FORTUP(alt = (Node), N_LIST(choice_list), ft2);
  1259.                 /* find the variant selected by given value of discriminant.
  1260.                     * all choices are now discrete ranges.
  1261.                  */
  1262.                 lo = INTV((Const)N_VAL(N_AST1(alt)));
  1263.                 hi = INTV((Const)N_VAL(N_AST2(alt)));
  1264.                 if (lo <= discr_value && discr_value <= hi) {
  1265.                     exists = TRUE;
  1266.                     break;
  1267.                 }
  1268.             ENDFORTUP(ft2);
  1269.             if (exists) {
  1270.                 /* Variants may be nested.*/
  1271.                 invariant_node = N_AST1(component_list);
  1272.                 variant_node = N_AST2(component_list);
  1273.                 /*all_component_names +:= build_comp_names(invariant_node);*/
  1274.                 btup = build_comp_names(invariant_node);
  1275.                 FORTUP(bs = (Symbol), btup, ft1);
  1276.                     all_component_names = tup_with(all_component_names,
  1277.                       (char *) bs);
  1278.                 ENDFORTUP(ft1);
  1279.                 tup_free(btup);
  1280.                 found_discr_value = TRUE;
  1281.                 break /*quit forall case_node*/;
  1282.             }
  1283.         ENDFORTUP(ft1);
  1284.  
  1285.         if (!found_discr_value) {
  1286.             if (others_comp_list != (Node)0) {
  1287.                 invariant_node = N_AST1(others_comp_list);
  1288.                 variant_node = N_AST2(others_comp_list);
  1289.                 btup = build_comp_names(invariant_node);
  1290.                 FORTUP(bs = (Symbol), btup, ft1);
  1291.                     all_component_names = tup_with(all_component_names,
  1292.                       (char *)bs);
  1293.                 ENDFORTUP(ft1);
  1294.                 tup_free(btup);
  1295.                 /*all_component_names +:=build_comp_names(invariant_node);*/
  1296.             }
  1297.             else {
  1298.                 create_raise(expn, symbol_constraint_error);
  1299.                 tup_free(components_seen);
  1300.                 return;
  1301.             }
  1302.         }
  1303.     }
  1304.  
  1305.     comp_pos = 1;       /* Index into list of selector assignments.*/
  1306.  
  1307.     /*components_seen = tup_new(0);  now allocated at start of proc*/
  1308.  
  1309.     if (cdebug2 > 0) {
  1310.         TO_ERRFILE("record fields are: ");
  1311.     }
  1312.     /* The list of component asssociations is built with pairs name -> expr
  1313.      * for all components present, including discriminants.
  1314.      */
  1315.     /*comp_assoc_list := [new_comp_assoc(d, v) : [d, v] in discr_map];*/
  1316.     comp_assoc_list = tup_new(tup_size(discr_map)/2);
  1317.     for (ctupi = 1; ctupi <= tup_size(discr_map); ctupi += 2) {
  1318.         ctupd = (Symbol) discr_map[ctupi];
  1319.         ctupn = (Node) discr_map[ctupi+1];
  1320.         comp_assoc_list[(ctupi+1)/2] = (char *) new_comp_assoc(ctupd, ctupn);
  1321.     }
  1322.     /* Perform resolution of all components following the positional
  1323.      * discriminants. Skip over named associations which are discriminants
  1324.      * since these have already been resolved.
  1325.      */
  1326.     for(i = i1+1; i <= tup_size(arg_list); i++) {
  1327.         comp_assoc = (Node) arg_list[i];
  1328.         if (N_KIND(comp_assoc) == as_choice_list) {
  1329.             choice_list = N_AST1(comp_assoc);
  1330.             c_expr = N_AST2(comp_assoc);
  1331.             choices = tup_new(0);
  1332.  
  1333.             FORTUP(choice_node = (Node), N_LIST(choice_list), ft1);
  1334.                 if (N_KIND(choice_node) == as_choice_unresolved) {
  1335.                     simple_name = N_AST1(choice_node);
  1336.                     sel = N_VAL(simple_name);
  1337.                     current_node = simple_name;
  1338.                     check_void(sel);
  1339.                     selector = dcl_get(sel_names, sel);
  1340.                     if (selector == (Symbol)0) {
  1341.                         errmsg("Undefined component name","4.3.1", simple_name);
  1342.                         tup_free(components_seen);
  1343.                         return;
  1344.                     }
  1345.                     choices = tup_with(choices, (char *) selector);
  1346.                     if (tup_mem((char *)selector, components_seen)) {
  1347.                         errmsg("Duplicate value for component in aggregate",
  1348.                           "4.3.1", simple_name);
  1349.                         tup_free(components_seen);
  1350.                         return;
  1351.                     }
  1352.                     else {
  1353.                         if (!tup_mem((char *)selector, components_seen))
  1354.                             components_seen =
  1355.                               tup_with(components_seen, (char *)selector);
  1356.                         if (NATURE(selector) != na_discriminant) {
  1357.                             if (tup_size(N_LIST(choice_list))> 1)
  1358.                                 /* copy expression node for each choice.*/
  1359.                                 e = copy_tree(c_expr);
  1360.                             else
  1361.                                 e = c_expr;
  1362.                             resolve_r_component(e, selector, discr_map);
  1363.                             comp_assoc_list = tup_with(comp_assoc_list,
  1364.                               (char *)new_comp_assoc(selector, e));
  1365.                         }
  1366.                         comp_pos += 1;
  1367.                     }
  1368.                 }
  1369.  
  1370.                 else if (N_KIND(choice_node) == as_simple_choice) {
  1371.                     errmsg("choice in record aggregate must be selector name",
  1372.                       "4.3.1", choice_node);
  1373.                     tup_free(components_seen);
  1374.                     return;
  1375.                 }
  1376.                 else if (N_KIND(choice_node) == as_range_choice) {
  1377.                     errmsg("Range choice not allowed in record aggregate",
  1378.                       "4.3.1", choice_node);
  1379.                     tup_free(components_seen);
  1380.                     return;
  1381.                 }
  1382.                 else if (N_KIND(choice_node) == as_others_choice) {
  1383.                     leftovers = tup_new(0);
  1384.                     FORTUP(selector = (Symbol), all_component_names, ft2);
  1385.                         if (!tup_mem((char *)selector, components_seen)) {
  1386.                             if (!tup_mem((char *) selector, leftovers))
  1387.                                 leftovers=tup_with(leftovers, (char *)selector);
  1388.                         }
  1389.                     ENDFORTUP(ft2);
  1390.  
  1391.                     if (tup_size( leftovers) == 0) {
  1392.                         errmsg_l("OTHERS choice must represent at least ",
  1393.                           "one component", "4.3.1", choice_node);
  1394.                         tup_free(components_seen);
  1395.                         return;
  1396.                     }
  1397.                     else {
  1398.                         FORTUP(selector = (Symbol), leftovers, ft2);
  1399.                             if(! tup_mem((char *)selector, components_seen))
  1400.                                 components_seen = tup_with(components_seen, 
  1401.                                   (char *) selector);
  1402.                             if (NATURE(selector) != na_discriminant) {
  1403.                                 if (tup_size(leftovers)> 1) {
  1404.                                     /* copy expression node.*/
  1405.                                     e = copy_tree(c_expr);
  1406.                                 }
  1407.                                 else {
  1408.                                     e = c_expr;
  1409.                                 }
  1410.                                 resolve_r_component(e, selector, discr_map);
  1411.                                 if (N_TYPE(c_expr) == symbol_any) {
  1412.                                     errmsg_id(
  1413.                                       "OTHERS expression incompatible with %",
  1414.                                       selector, "4.3.1", choice_node);
  1415.                                     tup_free(components_seen);
  1416.                                     return;
  1417.                                 }
  1418.                                 comp_assoc_list = tup_with(comp_assoc_list,
  1419.                                   (char *)new_comp_assoc(selector, e));
  1420.                             }
  1421.                             choices = tup_with(choices, (char *) selector);
  1422.                         ENDFORTUP(ft2);
  1423.                     }
  1424.                 }
  1425.             ENDFORTUP(ft1);
  1426.  
  1427.             ttup= tup_new(0);
  1428.             FORTUP(selector = (Symbol), choices, ft2);
  1429.                 btype = base_type(TYPE_OF(selector));
  1430.                 if (!tup_mem((char *) btype, ttup))
  1431.                     ttup = tup_with(ttup, (char *) btype);
  1432.             ENDFORTUP(ft2);
  1433.             if (tup_size(ttup) > 1) {
  1434.                 errmsg("components on a choice list must have same type",
  1435.                   "4.3.1", choice_list);
  1436.             }
  1437.             tup_free(ttup);
  1438.         }
  1439.         else {    /* Positional record aggregate. */
  1440.             if (comp_pos > tup_size(all_component_names)) {
  1441.                 errmsg("Too many components for record aggregate","none", expn);
  1442.                 tup_free(components_seen);
  1443.                 return;
  1444.             }
  1445.             selector = (Symbol) all_component_names[comp_pos];
  1446.             resolve_r_component(comp_assoc, selector, discr_map);
  1447.             comp_pos += 1;
  1448.             if (!tup_mem((char *) selector, components_seen))
  1449.                 components_seen = tup_with(components_seen, (char *) selector);
  1450.             comp_assoc_list = tup_with(comp_assoc_list,
  1451.               (char *) new_comp_assoc(selector, comp_assoc));
  1452.         }
  1453.     }
  1454.  
  1455.     exists = FALSE;
  1456.     FORTUP(selector = (Symbol), all_component_names, ft1);
  1457.         if (!tup_mem((char *) selector, components_seen)) {
  1458.             exists = TRUE;
  1459.             break;
  1460.         }
  1461.     ENDFORTUP(ft1);
  1462.     if (exists)  {
  1463.         errmsg_id("No value supplied for component %", selector, "4.3.1",
  1464.           current_node);
  1465.         tup_free(components_seen);
  1466.         return;
  1467.     }
  1468.     for (i = 1; i <= tup_size(comp_assoc_list); i++) {
  1469.         if (N_KIND(N_AST2((Node)comp_assoc_list[i])) == as_raise) {
  1470.             create_raise(expn, symbol_constraint_error);
  1471.             return;
  1472.         }
  1473.     }
  1474.     N_UNQ(expn) = sym_new(na_void);
  1475.     N_KIND(expn) = as_record_aggregate;
  1476.     N_LIST(expn) = (Tuple)0; /* clear out n_list */
  1477.     list_node = node_new(as_list);
  1478.     N_LIST(list_node) = comp_assoc_list;
  1479.     lnode = node_new(as_aggregate_list);
  1480.     N_AST1(lnode) = list_node;
  1481.     N_AST2(lnode) = OPT_NODE;
  1482.     N_AST1(expn) = lnode;
  1483.     N_AST2(expn) = OPT_NODE;
  1484. }
  1485.  
  1486. static Node new_comp_assoc(Symbol selector, Node expn)         /*;new_comp_assoc*/
  1487. {
  1488.     /* Used to normalize the representation of record aggregates: associate
  1489.      * a selector name with the expression given for it in the aggregate.
  1490.      */
  1491.  
  1492.     Node    c_node;
  1493.  
  1494.     c_node = node_new(as_record_choice);
  1495.     N_AST1(c_node) = new_name_node(selector);
  1496.     N_AST2(c_node) = expn;
  1497.     copy_span(expn, N_AST1(c_node));
  1498.     return c_node;
  1499. }
  1500.  
  1501. Tuple build_comp_names(Node invariant_node)    /*;build_comp_names*/
  1502. {
  1503.     /* Collect names of record components in the invariant part of the
  1504.      * record. Skip nodes generated for internal anonymous types.
  1505.      */
  1506.  
  1507.     Tuple    all_component_names;
  1508.     Node    node, id_list_node, id_node;
  1509.     Fortup    ft1, ft2;
  1510.  
  1511.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  build_comp_names");
  1512.  
  1513.     all_component_names = tup_new(0);
  1514.     FORTUP(node = (Node), N_LIST(invariant_node), ft1);
  1515.         if (N_KIND(node) == as_subtype_decl || N_KIND(node) == as_delayed_type)
  1516.             continue;
  1517.         id_list_node = N_AST1(node);
  1518.         FORTUP(id_node = (Node), N_LIST(id_list_node), ft2);
  1519.         /* test against 0 needed since in SETL om added at end of tuple
  1520.          * has no effect!    ds 14 aug
  1521.          * Skip over 'constrained' bit added by code generator (case of a
  1522.          * separately compiled record type definition.
  1523.          */
  1524.         if (N_UNQ(id_node) != (Symbol)0)
  1525.             all_component_names = tup_with(all_component_names,
  1526.               (char *) N_UNQ(id_node));
  1527.         ENDFORTUP(ft2);
  1528.     ENDFORTUP(ft1);
  1529.     return all_component_names;
  1530. }
  1531.  
  1532. static void resolve_r_component(Node e, Symbol selector, Tuple discr_map)
  1533.                                                     /*;resolve_r_component.*/
  1534. {  
  1535.     Symbol comp_type;
  1536.  
  1537.     resolve1(e);
  1538.     if (!noop_error) {
  1539.         comp_type = TYPE_OF(selector);
  1540.         /* if its bounds depend on discriminants, we emit subtypes with
  1541.          * the actual values of the discriminants given in the aggr. 
  1542.          */
  1543.         comp_type = check_discriminant_dependence(comp_type, discr_map);
  1544.         res2_check(e, comp_type);
  1545.     }
  1546. }
  1547.  
  1548. static Symbol check_discriminant_dependence(Symbol comp_type, Tuple discr_map)
  1549.                                             /*;check_discriminant_dependence*/
  1550. {
  1551.     /* if the subtype indication of a record component depends on a
  1552.      * discriminant, then the expression in a record aggregate that corresponds
  1553.      * to this component is given a subtype that is constrained by the values
  1554.      * of the discriminants that appear in the aggregate itself.
  1555.      */
  1556.  
  1557.     Tuple   constraint, new_constraint, tup, new_indices;
  1558.     Node    ubd, lbd, e;
  1559.     Symbol  d, type_name, index, new_index, new_type, new_acc;
  1560.     Tuple   comp_discr_map, new_discr_map;
  1561.     int     i, newi, new_t;
  1562.     Fortup  ft1;
  1563.  
  1564.     if (tup_size(discr_map) == 0) return comp_type;
  1565.  
  1566.     type_name = (is_access(comp_type)) ? (Symbol)designated_type(comp_type):
  1567.       comp_type;
  1568.  
  1569.     if (is_array(type_name)) {
  1570.         tup = index_types(type_name);
  1571.         new_indices = tup_new(0);
  1572.         FORTUP(index = (Symbol), tup, ft1)
  1573.             constraint = SIGNATURE(index);
  1574.             lbd = (Node)constraint[2];
  1575.             ubd = (Node)constraint[3];
  1576.             newi = FALSE;
  1577.             if (N_KIND(lbd) == as_discr_ref) {
  1578.                 lbd = discr_map_get(discr_map, N_UNQ(lbd));
  1579.                 newi = TRUE;
  1580.             }
  1581.             if (N_KIND(ubd) == as_discr_ref) {
  1582.                 ubd = discr_map_get(discr_map, N_UNQ(ubd));
  1583.                 newi = TRUE;
  1584.             }
  1585.             if (newi) {
  1586.                 new_index = sym_new(na_subtype);
  1587.                 dcl_put(DECLARED(scope_name), str_newat(), new_index);
  1588.                 new_constraint = constraint_new(CONSTRAINT_RANGE);
  1589.                 new_constraint[2]    = (char *)lbd;
  1590.                 new_constraint[3]    = (char *)ubd;
  1591.                 TYPE_OF(new_index)   = TYPE_OF(index);
  1592.                 SIGNATURE(new_index) = new_constraint;
  1593.                 SCOPE_OF(new_index)  = scope_name;
  1594.                 ALIAS      (new_index) = ALIAS(index);
  1595.                 new_indices = tup_with(new_indices, (char *)new_index);
  1596.                 new_t = TRUE;
  1597.             }
  1598.             else new_indices = tup_with(new_indices, (char *)index);
  1599.         ENDFORTUP(ft1);
  1600.         if (new_t) {
  1601.             /* create new subtype of array type, using new index types, and
  1602.              * label aggregate with this new array subtype.
  1603.              */
  1604.             new_type = sym_new(na_subtype);
  1605.             dcl_put(DECLARED(scope_name), str_newat(), new_type);
  1606.             TYPE_OF(new_type)      = base_type(type_name);
  1607.             SIGNATURE(new_type)    = tup_new(2);
  1608.             SIGNATURE(new_type)[1] = (char *)new_indices;
  1609.             SIGNATURE(new_type)[2] = (char *)component_type(type_name);
  1610.             SCOPE_OF(new_type)     = scope_name;
  1611.             ALIAS(new_type)        = ALIAS(type_name);
  1612.         }
  1613.         else {
  1614.             tup_free(new_indices);
  1615.             return comp_type;
  1616.         }
  1617.     }
  1618.     else if (NATURE(type_name) == na_subtype && is_record(type_name)) {
  1619.         /* see if any discriminant constraint is itself given by a discrimi-
  1620.          * nant (which must be a discriminant of the enclosing record.
  1621.          */
  1622.         comp_discr_map = (Tuple)numeric_constraint_discr(SIGNATURE(type_name));
  1623.         new_discr_map = tup_new(0);
  1624.         newi = FALSE;
  1625.         for (i = 1; i <= tup_size(comp_discr_map); i += 2) {
  1626.             d = (Symbol)comp_discr_map[i];
  1627.             e = (Node)  comp_discr_map[i+1];
  1628.             if (N_KIND(e) == as_discr_ref) {
  1629.                 /* replace discriminant reference with value given in enclosing
  1630.                  * aggregate.
  1631.                  */
  1632.                 newi = TRUE;
  1633.                 new_discr_map = discr_map_put(new_discr_map, d,
  1634.                   copy_tree(discr_map_get(discr_map, N_UNQ(e))));
  1635.             }
  1636.             else
  1637.                 new_discr_map = discr_map_put(new_discr_map, d, e);
  1638.         }
  1639.         if (newi) {
  1640.             new_type = sym_new(na_subtype);
  1641.             dcl_put(DECLARED(scope_name), str_newat(), new_type);
  1642.             tup = constraint_new(CONSTRAINT_DISCR);
  1643.             numeric_constraint_discr(tup) = (char *)new_discr_map;
  1644.             TYPE_OF(new_type)      = TYPE_OF(type_name);
  1645.             SIGNATURE(new_type)    = tup;
  1646.             OVERLOADS(new_type)    = OVERLOADS(type_name);
  1647.             SCOPE_OF(new_type)     = scope_name;
  1648.             ALIAS(new_type)        = ALIAS(type_name);
  1649.         }
  1650.         else {
  1651.             tup_free(new_discr_map);
  1652.             return comp_type;
  1653.         }
  1654.     }
  1655.     else {
  1656.         /* cannot be a discriminant constraint.*/
  1657.         return comp_type;
  1658.     }
  1659.     if (is_access(comp_type)) {
  1660.         /* create access type to new constrained array type.*/
  1661.         new_acc = sym_new(na_subtype);
  1662.         dcl_put(DECLARED(scope_name), str_newat(), new_acc);
  1663.         TYPE_OF(new_acc)      = TYPE_OF(comp_type);
  1664.         SIGNATURE(new_acc)    = constraint_new(CONSTRAINT_ACCESS);
  1665.         SIGNATURE(new_acc)[2] = (char *)new_type;    /*designated type*/
  1666.         SCOPE_OF(new_acc)     = scope_name;
  1667.         ALIAS(new_acc)        = ALIAS(comp_type);
  1668.         return new_acc;
  1669.     }
  1670.     else
  1671.         return new_type;
  1672. }
  1673.  
  1674. void valid_task_name(Node task_name)                     /*;valid_task_name*/
  1675. {
  1676.     /* First pass over an expression that must yield a task type: called to
  1677.      * resolve entry names.
  1678.      */
  1679.  
  1680.     Set    task_types;
  1681.     Forset    fs1;
  1682.     Symbol    t;
  1683.  
  1684.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : valid_task_name");
  1685.  
  1686.     resolve1(task_name);
  1687.     task_types = set_new(0);
  1688.     FORSET(t = (Symbol), N_PTYPES(task_name), fs1);
  1689.         if (is_task_type(t)
  1690.           || (is_access(t) && is_task_type(designated_type(t))))
  1691.             task_types = set_with(task_types, (char *) t);
  1692.     ENDFORSET(fs1);
  1693.  
  1694.     if (set_size(task_types) == 0) {
  1695.         errmsg("expect task name ", "9.5", task_name);
  1696.     }
  1697.  
  1698.     N_PTYPES(task_name) = task_types;
  1699. }
  1700.  
  1701. void complete_task_name(Node task1, Symbol context_typ)  /*;complete_task_name*/
  1702. {
  1703.     /* Complete resolution of task name used in an entry name.The context_typ
  1704.      * is obtained from the    scope of  the resolved    entry name. Derived task
  1705.      * types have the same entries as their root type, and the unique type of
  1706.      * the task name is thus the one whose root type is the context type.
  1707.      */
  1708.  
  1709.     Node    a_task;
  1710.     Set    types;
  1711.     Symbol    t, tmp;
  1712.     int    exists;
  1713.     Forset    fs1;
  1714.     Symbol    t_n;
  1715.  
  1716.     if (cdebug2 > 3)  TO_ERRFILE("AT PROC : complete_task_name");
  1717.  
  1718.     types = N_PTYPES(task1);
  1719.     exists = FALSE;
  1720.     FORSET(t = (Symbol), types, fs1);
  1721.         if (root_type(t) == context_typ) {
  1722.             exists = TRUE;
  1723.             break;
  1724.         }
  1725.     ENDFORSET(fs1);
  1726.     if (exists) {
  1727.         resolve2(task1, t);
  1728.         if (N_KIND(task1) != as_simple_name) eval_static(task1);
  1729.     }
  1730.     else {
  1731.         exists = FALSE;
  1732.         FORSET(t = (Symbol), types, fs1);
  1733.             tmp =  (Symbol) designated_type(t);
  1734.             if (is_access(t) &&
  1735.                 root_type(tmp) == context_typ) {
  1736.                 exists = TRUE;
  1737.                 break;
  1738.             }
  1739.         ENDFORSET(fs1);
  1740.         if (exists) {
  1741.             resolve2(task1, t);
  1742.             if (N_KIND(task1) != as_simple_name) eval_static(task1);
  1743.             a_task = copy_node(task1);
  1744.             N_KIND(task1) = as_all; /* explicit dereference*/
  1745.             N_AST1(task1) = a_task; /* of access to task*/
  1746.             N_AST2(task1) = N_AST3(task1) = N_AST4(task1) = (Node) 0;
  1747.             N_TYPE(task1) = (Symbol) designated_type(t);
  1748.         }
  1749.         else { /* previous error.*/
  1750.             return;
  1751.         }
  1752.     }
  1753.     /* Within the task body a task type designates the object currently exe-
  1754.      * cuting that task. We replace the task type with  what will be     its
  1755.      * run-time identity.
  1756.      */
  1757.     t_n = N_UNQ(task1);
  1758.     if (N_KIND(task1) == as_simple_name && is_task_type(t_n)) {
  1759.         if (in_open_scopes(t_n))
  1760.             N_UNQ(task1) = dcl_get(DECLARED(t_n), "current_task");
  1761.         else {
  1762.             /* Use of the task type otherwise is invalid.*/
  1763.             errmsg("invalid use of task type outside of its own body", "9.1",
  1764.               task1);
  1765.         }
  1766.     }
  1767. }
  1768.  
  1769. void res2_check(Node expn2, Symbol context_type)            /*;res2_check*/
  1770. {
  1771.     /* Called to impose constraints when needed, on aggregate components
  1772.      * and allocated objects. These are non-sliding contexts for aggregates.
  1773.      */
  1774.  
  1775.     int may_others;
  1776.  
  1777.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  res2_check");
  1778.  
  1779.     may_others = full_others;
  1780.     full_others = TRUE;
  1781.     resolve2(expn2, context_type);
  1782.  
  1783.     apply_constraint(expn2, context_type);
  1784.     full_others = may_others;
  1785.     if (!noop_error)
  1786.         eval_static(expn2);
  1787. }
  1788.  
  1789. Symbol attribute_type(int attribute, Symbol typ, Node arg1, Node arg2)
  1790.                                                         /*;attribute_type*/
  1791. {
  1792.     /* -attribute- is a predefined attribute. arg1 is the first arg,
  1793.      * whose type is typ, and arg2 is the second argument (or a dummy 1).
  1794.      * The result type of an attribute is either a numeric type, or
  1795.      * the type of its first argument (    attributes of enumerations).
  1796.      * FIRST and LAST are more complicated : they return the first
  1797.      * value of the index type of the i'th dimension of their first
  1798.      * argument.
  1799.      * For enumeration types, FIRST and LAST simply return the type
  1800.      * of the first argument.
  1801.      */
  1802.  
  1803.     Symbol    n;
  1804.     Set        types2;
  1805.     int        dim;
  1806.     Symbol    a_type, root, t, t2;
  1807.     int        type_ok, exists;
  1808.     Forset    fs1;
  1809.     Unitdecl    ud;
  1810.  
  1811.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : attribute_type");
  1812.  
  1813.     n = N_UNQ(arg2);
  1814.     if ((N_KIND(arg2) == as_simple_name) && (n != (Symbol)0))
  1815.         N_PTYPES(arg2) = set_new1((char *) TYPE_OF(n));
  1816.     else
  1817.         resolve1(arg2);        /* Begin resolution of second arg*/
  1818.  
  1819.     types2 = N_PTYPES(arg2);
  1820.     if (types2 == (Set)0) types2 = set_new(0);
  1821.     if (set_size(types2) == 0)    /* Some type error .*/
  1822.         return symbol_any;
  1823.  
  1824.     if ( attribute == ATTR_O_FIRST || attribute == ATTR_T_FIRST
  1825.       || attribute == ATTR_O_LAST || attribute == ATTR_T_LAST
  1826.       || attribute == ATTR_O_RANGE || attribute == ATTR_T_RANGE
  1827.       || attribute == ATTR_O_LENGTH || attribute == ATTR_T_LENGTH) {
  1828.         /* The second argument must be a universal integer, and
  1829.          * and must be static. Complete its resolution now.
  1830.           */
  1831.         if (set_mem((char *) symbol_universal_integer, types2)) {
  1832.             resolve2(arg2, symbol_universal_integer);
  1833.             specialize(arg2, symbol_integer);
  1834.         }
  1835.         else
  1836.             pass1_error_str("index number of attribute % must be universal",
  1837.               attribute_str(attribute), "Appendix A", arg2);
  1838.  
  1839.         if (! is_static_expr(arg2)
  1840.           || N_KIND(arg2) != as_ivalue 
  1841.           || ((Const)N_VAL(arg2))->const_kind != CONST_INT) {
  1842.             pass1_error_str("Second argument of % must be static integer", 
  1843.               attribute_str(attribute), "3.6.2", arg2); /* ?? */
  1844.  
  1845.             dim = 1;    /* assume 1*/
  1846.         }
  1847.         else dim = INTV((Const)N_VAL(arg2));
  1848.  
  1849.         a_type = typ;
  1850.         if (is_array(typ)) {
  1851.             if (is_type_node(arg1) && can_constrain(N_UNQ(arg1))) {
  1852.                 pass1_error_str("Unconstrained array type for attribute %",
  1853.                   attribute_str(attribute), "3.6.2", arg1);
  1854.                 return symbol_any;
  1855.             }
  1856.             if ( (dim > no_dimensions(typ)) || (dim < 1)) {
  1857.                 pass1_error_l("Invalid dimension number for array type",
  1858.                   " in attribute", "3.6.2", arg1);
  1859.                 return symbol_any;
  1860.             }
  1861.             if (attribute == ATTR_O_LENGTH || attribute == ATTR_T_LENGTH)
  1862.                 a_type = symbol_universal_integer;
  1863.             else {
  1864.                 /* Get type of index for specified dimension.*/
  1865.                 a_type = (Symbol) index_types(a_type)[dim];
  1866.             }
  1867.         }
  1868.     }
  1869.     else if (attribute == ATTR_ADDRESS) {
  1870.         ud = unit_decl_get("spSYSTEM");
  1871.         if (ud == (Unitdecl)0 || !in_vis_mods(ud->ud_unam)) {
  1872.             /* The use of this attribute seems incorrect if its type
  1873.              * cannot be named.
  1874.              */
  1875.             errmsg("use of SYSTEM.ADDRESS requires presence of package SYSTEM",
  1876.               "13.7.2, Annex A", arg1);
  1877.             a_type = symbol_integer; /* Closest thing we've got.*/
  1878.         }
  1879.         else {
  1880.             /*a_type = ??visible('SYSTEM')('ADDRESS');*/
  1881.             a_type = dcl_get_vis(DECLARED(ud->ud_unam), "ADDRESS");
  1882.         }
  1883.     }
  1884.     else if (attribute != ATTR_BASE
  1885.       &&     attribute != ATTR_T_FIRST && attribute != ATTR_O_FIRST
  1886.       &&     attribute != ATTR_O_LAST && attribute != ATTR_T_LAST
  1887.       &&     attribute != ATTR_PRED
  1888.       &&     attribute != ATTR_O_RANGE && attribute != ATTR_T_RANGE
  1889.       &&     attribute != ATTR_SUCC
  1890.       &&     attribute != ATTR_VAL
  1891.       &&     attribute != ATTR_VALUE) {
  1892.  
  1893.         /*a_type = TYPE_OF(attribute);*/
  1894.         if ( attribute == ATTR_AFT
  1895.           || attribute == ATTR_COUNT
  1896.           || attribute == ATTR_DIGITS 
  1897.           || attribute == ATTR_EMAX 
  1898.           || attribute == ATTR_FIRST_BIT 
  1899.           || attribute == ATTR_FORE 
  1900.           || attribute == ATTR_LAST_BIT 
  1901.           || attribute == ATTR_LAST_BIT 
  1902.           || attribute == ATTR_O_LENGTH || attribute == ATTR_T_LENGTH 
  1903.           || attribute == ATTR_MACHINE_EMAX 
  1904.           || attribute == ATTR_MACHINE_EMIN 
  1905.           || attribute == ATTR_MACHINE_MANTISSA 
  1906.           || attribute == ATTR_MACHINE_RADIX 
  1907.           || attribute == ATTR_MANTISSA 
  1908.           || attribute == ATTR_POS 
  1909.           || attribute == ATTR_POSITION 
  1910.           || attribute == ATTR_SAFE_EMAX 
  1911.           || attribute == ATTR_O_SIZE || attribute == ATTR_T_SIZE 
  1912.           || attribute == ATTR_STORAGE_SIZE 
  1913.           || attribute == ATTR_WIDTH) {
  1914.             a_type = symbol_universal_integer;
  1915.         }
  1916.         else if (attribute == ATTR_DELTA
  1917.           ||     attribute == ATTR_EPSILON    
  1918.           ||     attribute == ATTR_LARGE    
  1919.           ||     attribute == ATTR_SMALL    
  1920.           ||     attribute == ATTR_SAFE_LARGE    
  1921.           ||     attribute == ATTR_SAFE_SMALL) {
  1922.             a_type = symbol_universal_real;
  1923.         }
  1924.         else if (attribute==ATTR_O_CONSTRAINED || attribute==ATTR_T_CONSTRAINED
  1925.           ||     attribute == ATTR_MACHINE_OVERFLOWS    
  1926.           ||     attribute == ATTR_MACHINE_ROUNDS    
  1927.           ||     attribute == ATTR_CALLABLE    
  1928.           ||     attribute == ATTR_TERMINATED) {
  1929.             a_type = symbol_boolean;
  1930.         }
  1931.         else if (attribute == ATTR_IMAGE)
  1932.             a_type = symbol_string;
  1933.     }
  1934.     else if (attribute == ATTR_BASE
  1935.       ||     attribute == ATTR_POS
  1936.       ||     attribute == ATTR_PRED
  1937.       ||     attribute == ATTR_SUCC
  1938.       ||     attribute == ATTR_VAL
  1939.       ||     attribute == ATTR_VALUE) {
  1940.         a_type = base_type(typ);
  1941.     }
  1942.     else {
  1943.         a_type = typ;
  1944.     }
  1945.  
  1946.     root = root_type(typ);
  1947.  
  1948.     /* Now verify that the type of the argument is valid for the attribute.*/
  1949.  
  1950.     t = N_UNQ(arg1);
  1951.     if (t != (Symbol)0 && tup_mem((char *) t, open_scopes)
  1952.       && NATURE(t) == na_record) {
  1953.         errmsg_id("Invalid self-reference in definition of %", t, "3.1", arg1);
  1954.          /* ?? */
  1955.         return symbol_any;
  1956.     }
  1957.  
  1958.     if (attribute == ATTR_ADDRESS)
  1959.         type_ok =  !is_type_node(arg1);
  1960.     else if (attribute == ATTR_BASE)
  1961.         type_ok =      is_type(root);
  1962.     else if (attribute == ATTR_T_FIRST || attribute == ATTR_O_FIRST
  1963.       || attribute == ATTR_O_LAST || attribute == ATTR_T_LAST)
  1964.         type_ok =  is_scalar_type(root) || is_array(root);
  1965.     else if (attribute == ATTR_VALUE) {
  1966.         if (!is_discrete_type(root))
  1967.             type_ok = FALSE;
  1968.         else {
  1969.             exists = FALSE;
  1970.             FORSET(t2 = (Symbol), types2, fs1);
  1971.                 if (compatible_types(symbol_string, t2)) {
  1972.                     exists = TRUE;
  1973.                     break;
  1974.                 }
  1975.             ENDFORSET(fs1);
  1976.             type_ok = exists;
  1977.         }
  1978.     }
  1979.     else if (attribute == ATTR_IMAGE
  1980.       ||     attribute == ATTR_POS
  1981.       ||     attribute == ATTR_PRED
  1982.       ||     attribute == ATTR_SUCC) {
  1983.         if (! is_discrete_type(root))
  1984.             type_ok = FALSE;
  1985.         else {
  1986.             exists = FALSE;
  1987.             FORSET(t2 = (Symbol), types2, fs1);
  1988.                 if (compatible_types(typ, t2)) {
  1989.                     exists = TRUE;
  1990.                     break;
  1991.                 }
  1992.             ENDFORSET(fs1);
  1993.             type_ok =  exists;
  1994.         }
  1995.     }
  1996.     else if (attribute == ATTR_VAL) {
  1997.         if (!is_discrete_type(root))
  1998.             type_ok = FALSE;
  1999.         else {
  2000.             exists = FALSE;
  2001.             FORSET(t2 = (Symbol), types2, fs1);
  2002.                 if (is_integer_type(root_type(t2))) {
  2003.                     exists = TRUE;
  2004.                     break;
  2005.                 }
  2006.             ENDFORSET(fs1);
  2007.             type_ok =  exists;
  2008.         }
  2009.     }
  2010.     else if (attribute == ATTR_AFT
  2011.       ||     attribute == ATTR_DELTA
  2012.       ||     attribute == ATTR_FORE) {
  2013.         type_ok =   is_fixed_type(root);
  2014.     }
  2015.     else if (attribute == ATTR_DIGITS
  2016.       ||     attribute == ATTR_EMAX
  2017.       ||     attribute == ATTR_EPSILON
  2018.       ||     attribute == ATTR_MACHINE_RADIX
  2019.       ||     attribute == ATTR_MACHINE_MANTISSA
  2020.       ||     attribute == ATTR_MACHINE_EMAX
  2021.       ||     attribute == ATTR_MACHINE_EMIN
  2022.       ||     attribute == ATTR_SAFE_EMAX) {
  2023.         type_ok =        root == symbol_float;
  2024.     }
  2025.     else if (attribute == ATTR_LARGE
  2026.       ||    attribute == ATTR_MACHINE_ROUNDS
  2027.       ||    attribute == ATTR_MACHINE_OVERFLOWS
  2028.       ||    attribute == ATTR_MANTISSA
  2029.       ||    attribute == ATTR_SMALL
  2030.       ||    attribute == ATTR_SAFE_LARGE
  2031.       ||    attribute == ATTR_SAFE_SMALL) {
  2032.         if (is_fixed_type(root) || root == symbol_float)
  2033.             type_ok = TRUE;
  2034.         else
  2035.             type_ok = FALSE;
  2036.     }
  2037.     else if (attribute == ATTR_O_LENGTH || attribute == ATTR_T_LENGTH
  2038.       || attribute == ATTR_O_RANGE || attribute == ATTR_T_RANGE)
  2039.         type_ok = is_array(root);
  2040.     else if (attribute==ATTR_O_CONSTRAINED || attribute == ATTR_T_CONSTRAINED) {
  2041.         if (is_type_node(arg1))
  2042.             type_ok = is_private(typ);
  2043.         else if ( is_record(root) && has_discriminants(root))
  2044.             type_ok = TRUE;
  2045.         else
  2046.             type_ok = FALSE;
  2047.     }
  2048.     else if (attribute == ATTR_TERMINATED || attribute == ATTR_CALLABLE) {
  2049.         if (is_access(root)) root = (Symbol) designated_type(root);
  2050.         type_ok =  is_task_type(root);
  2051.     }
  2052.     else if (attribute == ATTR_STORAGE_SIZE)
  2053.         type_ok =  (is_task_type(root) || is_access(root));
  2054.     else if (attribute == ATTR_WIDTH)
  2055.         type_ok = is_discrete_type(root);
  2056.  
  2057.     else if (attribute == ATTR_COUNT
  2058.       ||    attribute == ATTR_FIRST_BIT
  2059.       ||    attribute == ATTR_LAST_BIT
  2060.       ||    attribute == ATTR_O_SIZE || attribute == ATTR_T_SIZE
  2061.       ||    attribute == ATTR_POSITION) {
  2062.         type_ok =  TRUE;
  2063.     }
  2064.  
  2065.     else {
  2066.         errmsg_str("Undefined attribute: %", attribute_str(attribute),
  2067.           "Annex A", arg1);
  2068.         a_type = symbol_any;
  2069.         type_ok = TRUE;
  2070.     }
  2071.  
  2072.     if (type_ok) return a_type;
  2073.     else {
  2074.         pass1_error_str("Invalid argument type for attribute %",
  2075.           attribute_str(attribute), "Annex A", arg1);
  2076.         return symbol_any;
  2077.     }
  2078. }
  2079.  
  2080. int compatible_types(Symbol t_out, Symbol t_in) /*;compatible_types*/
  2081. {
  2082.     /* This procedure verifies that an expression of type -t_in- can appear
  2083.      * in a context requiring type -t_out-. In the case of subtypes this
  2084.      * procedure indicates whether a run-time check will be necessary.
  2085.      * Equality, set and comparison operators carry a special type-marker which
  2086.      * is ignored on the first pass of type resolution, because the type of
  2087.      * the arguments of these operators have no effect on the result type.
  2088.      * On the second pass, these special type-markers are used to indicate
  2089.      * the need for a consistency check among the types of the two actual
  2090.      * parameters themselves.
  2091.      */
  2092.  
  2093.     Symbol    r;
  2094.     int    n;
  2095.     Symbol tmp;
  2096.  
  2097.     if (cdebug2 > 0) {
  2098.         TO_ERRFILE("check compatible types ");
  2099.         printf("  %s %s\n", ((t_out != (Symbol)0) ? ORIG_NAME(t_out): ""),
  2100.           ((t_in != (Symbol) 0)? ORIG_NAME(t_in) : ""));
  2101.     }
  2102.     if (t_in == (Symbol)0 || t_out == (Symbol)0    /* syntax error*/
  2103.       || (t_in == t_out)    /*compatible types*/
  2104.       || in_multiple_types(t_in) || in_multiple_types(t_out)) {
  2105.         return TRUE;
  2106.     }
  2107.     /* The generic types 'universal_integer', 'universal_real', 'string_type'
  2108.      * and '$FIXED' are used to indicate the type of the corresponding literals.
  2109.      * These types are compatible with specific types of the same family.
  2110.      * On the other hand, the generic 'universal_fixed' is incompatible
  2111.      * with all types, and its presence in any type checking will trigger an
  2112.      * error message, at some point.
  2113.      * To avoid checking for their presence on both sides, we perform the
  2114.      * following normalization :
  2115.      */
  2116.     if (!in_gen_types(t_in) && in_gen_types(t_out)) {
  2117.         tmp = t_in; 
  2118.         t_in = t_out; 
  2119.         t_out = tmp;
  2120.     }
  2121.  
  2122.     if (t_in == symbol_universal_integer)
  2123.         return ( root_type(t_out) == symbol_integer);
  2124.     else if(t_in == symbol_universal_real)
  2125.         return (root_type(t_out) == symbol_float ||
  2126.           (t_out != symbol_universal_fixed && is_fixed_type(root_type(t_out))));
  2127.     else if (t_in == symbol_universal_type)
  2128.         return in_univ_types(t_out);
  2129.     else if (t_in == symbol_dfixed)
  2130.         return (t_out == symbol_universal_real || is_fixed_type(t_out));
  2131.     else if (t_in == symbol_boolean_type)
  2132.         return (root_type(t_out) == symbol_boolean || (is_array(t_out)
  2133.           && root_type((Symbol) component_type(t_out)) == symbol_boolean));
  2134.     else if (t_in == symbol_discrete_type)
  2135.         return(        is_discrete_type(t_out));
  2136.     else if(t_in == symbol_integer_type)
  2137.         return (root_type(t_out) == symbol_integer
  2138.           || t_out == symbol_universal_integer);
  2139.     else if (t_in == symbol_real_type) {
  2140.         r = root_type(t_out);
  2141.         return (r == symbol_float 
  2142.           || (r != symbol_universal_fixed && is_fixed_type(r))
  2143.           || r == symbol_universal_real);
  2144.     }
  2145.     else if(t_in == symbol_string_type)
  2146.         return (is_array(t_out) && no_dimensions(t_out) ==  1
  2147.           && is_character_type(component_type(t_out)));
  2148.     else if(t_in == symbol_character_type)
  2149.         return(is_character_type(t_out));
  2150.     else if (t_in == symbol_array_type)
  2151.         return(is_array(t_out));
  2152.     else if (t_in == symbol_composite_type) {
  2153.         n = NATURE(root_type(t_out));
  2154.         return(n == na_array || n == na_record);
  2155.     }
  2156.     else if(t_in == symbol_universal_fixed)
  2157.         return     FALSE;
  2158.     else
  2159.         /* name equivalence of base types holds for everything else.*/
  2160.         return  (base_type(t_in) == base_type(t_out));
  2161. }
  2162.  
  2163. static int in_gen_types(Symbol t)                         /*;in_gen_types*/
  2164. {
  2165.     return (
  2166.         t == symbol_array_type    
  2167.      || t == symbol_boolean_type  
  2168.      || t == symbol_character_type 
  2169.      || t == symbol_composite_type
  2170.      || t == symbol_discrete_type 
  2171.      || t == symbol_dfixed
  2172.      || t == symbol_integer_type   
  2173.      || t == symbol_real_type
  2174.      || t == symbol_string_type     
  2175.      || t == symbol_universal_integer 
  2176.      || t == symbol_universal_real
  2177.      || t == symbol_universal_fixed 
  2178.      || t == symbol_universal_type);
  2179. }
  2180.  
  2181. static int in_multiple_types(Symbol t)  /*;in_multiple_types*/
  2182. {
  2183.     return (t == symbol_equal_type
  2184.       ||    t == symbol_order_type
  2185.       ||    t == symbol_any);
  2186. }
  2187.  
  2188. void type_error(Set op_names, Symbol typ, int num_types, Node node)
  2189.                                                                 /*;type_error*/
  2190. {
  2191.     /* Emit error message after a type error was detected during
  2192.      * type resolution.
  2193.      * if num_types > 1, the expression is ambiguous : the operator of
  2194.      * op_names is overloaded, and the argument list is not sufficient to
  2195.      * disambiguate.
  2196.      * If num_types = 0, the argument list is incompatible with the op.
  2197.      */
  2198.  
  2199.     Symbol    op_name;
  2200.     char    *op_n; /*TBSL: check type of op_n*/
  2201.     char    *names;
  2202.     int        nat;
  2203.  
  2204.     if (cdebug2 > 3) {
  2205.         TO_ERRFILE("AT PROC :  type_error");
  2206. #ifdef TBSL
  2207.         TO_ERRFILE('opname=' + str op_names);
  2208. #endif
  2209.     }
  2210.  
  2211.     /* avoid taking set_arb of empty set    ds 8 aug */
  2212.     if (set_size(op_names) == 0)
  2213.         op_name = (Symbol)symbol_undef;
  2214.         /* this should parallel SETL   gcs 19 feb 
  2215.          * Looks like noop_error should be set (but is not) 
  2216.          */
  2217.     else
  2218.         op_name = (Symbol) set_arb(op_names);
  2219.  
  2220.     op_n = ORIG_NAME(op_name);
  2221.     if (N_KIND(node) == as_simple_name)
  2222.         N_UNQ(node) = op_name;    /* to avoid cascaded errors */
  2223.     if (num_types > 1) {
  2224.         nat = NATURE(op_name);
  2225.  
  2226.         if (nat == na_procedure || nat == na_function 
  2227.           || nat == na_procedure_spec || nat == na_function_spec) {
  2228. #ifdef TBSL
  2229.             names :
  2230.                 = +/[original_name(scope_of(x)) + '.' +
  2231.                     original_name(x) + ' ' : x in  op_names];
  2232. #endif
  2233.             names = build_full_names(op_names);
  2234.             errmsg_str("Ambiguous call to one of %", names, "6.6, 8.3", node);
  2235.         }
  2236.         else if (nat == na_op) {
  2237.             errmsg_str("Ambiguous operands for %", op_n, "6.7, 8.3", node);
  2238.         }
  2239.         else if (nat == na_literal) {
  2240.             errmsg_str("Ambiguous literal: %", op_n, "3.5.1, 4.7, 8.3", node);
  2241.         }
  2242.  
  2243.         else {
  2244.             errmsg("ambiguous expression", "8.2, 8.3", node);
  2245.         }
  2246.  
  2247.         /* If the type is ambiguous the expression is of couse invalid.*/
  2248.  
  2249.         noop_error = TRUE;
  2250.     }
  2251.     else {        /* Num_types is zero.*/
  2252.         if (noop_error) {
  2253.             /* Current expression contained previous error. Do not emit
  2254.              * an aditional one.
  2255.              */
  2256.             return;
  2257.         }
  2258.  
  2259.         noop_error = TRUE; /* For sure.*/
  2260.  
  2261.         if (typ == (Symbol) 0) {    /* Operator or subprogram .*/
  2262.             if (strcmp(op_n, "GET") == 0 || strcmp(op_n, "PUT") == 0) {
  2263.                 errmsg("TEXT_IO not instantiated nor defined for type",
  2264.                   "8.4, 14.4", node);
  2265.             }
  2266.             else {
  2267.                 if (NATURE(op_name) == na_entry
  2268.                   || NATURE(op_name) == na_entry_family) {
  2269.                     op_n = "entry call";
  2270.                 }
  2271.                 if (NATURE(op_name) == na_op)
  2272.                     errmsg_str("invalid types for %", op_n, "none", node);
  2273.                 else {
  2274.                     errmsg_str("invalid argument list for %",op_n,"none", node);
  2275.                 }
  2276.             }
  2277.         }
  2278.         else if (NATURE(op_name) == na_literal) {
  2279.             errmsg_id_type("no instance of % has type %", op_name, typ,
  2280.               "3.5.1", node);
  2281.         }
  2282.         else {
  2283.             errmsg_type("Expect expression to yield type %", typ, "none", node);
  2284.         }
  2285.     }
  2286. }
  2287.  
  2288. void premature_access(Symbol type_mark, Node node)         /*;premature_access*/
  2289. {
  2290.     /* Called when trying to use ( an access to) a fully private type.*/
  2291.     pass1_error_id("Premature usage of access, private or incomplete type %",
  2292.       type_mark, "7.4.2", node);
  2293.     return;
  2294. }
  2295.  
  2296. /* variations of this procedure are defined in errmsg.c */
  2297. void pass1_error(char *msg1, char *lrm_sec, Node node) /*;pass1_error*/
  2298. {
  2299.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  pass1_error");
  2300.  
  2301.     /* This procedure is invoked when a type error which requires a special
  2302.      * message is encountered in resolve1.
  2303.      */
  2304.  
  2305.     if (!noop_error)
  2306.         /* to avoid errmsg prepass */
  2307.         errmsg(msg1, lrm_sec, node);
  2308.     noop_error = TRUE;    /* To avoid cascaded errors.*/
  2309. }
  2310.  
  2311. char *full_type_name(Symbol typ)    /*;full_type_name*/
  2312. {
  2313.     /* Error message procedure. Restore source name of type, or if anonymous
  2314.      * build some approximate description of its ancestry.
  2315.      */
  2316.     /* Note that this is only called as part of error message and need ot
  2317.      * be provided until full error messages supported    ds 14 aug
  2318.      */
  2319.  
  2320.     char *type_name;
  2321.  
  2322.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  full_type_name");
  2323.  
  2324.     type_name = ORIG_NAME(typ);
  2325.     if (type_name == (char *)0 || strlen(type_name) == 0) { /* Anonymous type.*/
  2326.         /* TBSL: check above line for anonymous vs. undefined */
  2327.         if ( NATURE(typ) == na_subtype)
  2328.             type_name = full_type_name(TYPE_OF(typ));
  2329.         else if (NATURE(typ) == na_array)
  2330.             type_name = strjoin(strjoin("array(",
  2331.               full_type_name((Symbol) index_type(typ))), "...");
  2332.  
  2333.         else if (NATURE(typ) == na_type)        /* derived type */
  2334.             type_name = strjoin("new ", full_type_name(TYPE_OF(typ)));
  2335.         else type_name = strjoin("--anonymous--", "");
  2336.     }
  2337.     return type_name;
  2338. }
  2339.  
  2340. int is_type_node(Node node)                                    /*;is_type_node*/
  2341. {
  2342.     return (N_KIND(node) == as_simple_name && (is_type(N_UNQ(node))));
  2343. }
  2344.  
  2345. static int is_integer_type(Symbol sym)                    /*;is_integer_type*/
  2346. {
  2347.     return (sym == symbol_integer || sym == symbol_short_integer
  2348.       || sym == symbol_long_integer || sym == symbol_universal_integer);
  2349. }
  2350.  
  2351. static Triplet *triplet_new()
  2352. {
  2353.     return (Triplet *) emalloct(sizeof(Triplet), "triplet-new");
  2354. }
  2355.